Quorion Registrierkasse fernsteuern

qdriver.pl

#!/usr/bin/perl

# Quorion Registrierkasse fernsteuern
# - Berichte holen
# - Uhr stellen
# und vielleicht auch anderes
#
# Braucht ein POSIX System
# Konfiguration wie Windows QDriver


# Copyright (c) 2016-10-22 Hungerburg
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.


# ;; Beispielstapel
# VISIBLE=1
# PORT=9999
# IP=192.168.0.100
# REGISTER=1
# ;; Anmelden mit Kennwort
# COMMAND=LI666
# ;; Uhr stellen
# COMMAND=TSYSTEM
# ;; E-Journal holen
# DFILE=/tmp/Journal.csv
# COMMAND=RUx101001001
# COMMAND=LO

use IO::Socket;
use File::Basename;
use POSIX qw(strftime);
use strict;

# Some Globals
my ($DBG, $host, $port, $sock, $out);

# Network Commands
sub open_net {
	print "NET: $host:$port\n" if $DBG;
	$sock = IO::Socket::INET->new(
		Proto    => 'udp',
		PeerPort => $port,
		PeerAddr => $host
	) or die "Socket nicht angelegt: $!\n";
	# Nicht ewig warten: timeout nach 5 Sekunden
	setsockopt($sock, SOL_SOCKET, SO_RCVTIMEO, pack('L!L!', +5, 0));
}

sub send_net {
	my $data = shift;
	defined $sock->send($data) or die "Senden fehlgeschlagen: $!\n";
}

sub read_net {
	my $buf;
	while (1) {
		defined $sock->recv($buf, 1024) or die "Empfangen fehlgeschlagen: $!";
		die "Login fehlgeschlagen" if $buf =~ /^\x06\x3a/;
		last if $buf =~ /^\x06\x00/; # Übertragung Ende
		defined $out or die "Keine Ausgabedatei\n";
		print $out "$buf\r\n";
		send_net "\x{06}"; # ACK
		print "." if $DBG;
	}
	return unless defined $out;
	print "\n" if $DBG;
	close $out;
	undef $out;
}

# Internal Commands
my $opts = {
	TSYSTEM => sub {
		return strftime("T%H%M%S%d%m%Y", localtime());
	}
};

# Workers
sub set_dbg {
	$DBG = shift;
	return unless $DBG;
	print "DBG: VISIBLE=$DBG\n";
	$|++;
}

sub set_host {
	$host = shift;
	open_net if $host && $port;
}

sub set_port {
	$port = shift;
	$port = 2030 if $port == 9999;
	open_net if $host && $port;
}

sub set_register {
	my $reg = shift;
	die "Register nicht unterstützt" if $reg != 1;
}

sub do_command {
	die "Netzwerk nicht an\n" unless defined $sock;
	my $opt = shift;
	if (exists $opts->{$opt}) {
		$opt = $opts->{$opt}->();
		print "OPT: $opt\n" if $DBG;
	}
	send_net $opt;
	read_net;
}

sub do_nfile {
	my $path = shift;
	defined $out and close($out);
	print "OUT: $path\n" if $DBG;
	open($out, ">", $path) or die "Ausgabedatei nicht möglich: $!\n";
}

sub do_dfile {
	my $path = shift;
	my $time = strftime("%Y-%m-%dT%H-%M-%S", localtime());
	defined $out and close($out);
	my ($base, $dir, $ext) = fileparse($path, qr/\.[^.]*$/);
	$path = $dir . $base . "_" . $time . $ext;
	print "OUT: $path\n" if $DBG;
	open($out, ">", $path) or die "Ausgabedatei nicht möglich: $!\n";
}

# External Commands
my $cmds = {
	VISIBLE => \&set_dbg,
	PORT => \&set_port,
	IP => \&set_host,
	REGISTER => \&set_register,
	COMMAND => \&do_command,
	NEWFILE => \&do_nfile,
	DFILE => \&do_dfile
};

# Main
my $cfg = shift;
defined $cfg or die "Keine Stapeldatei angegeben\n";
open(FILE, "<:crlf", $cfg) or die "Fehler Stapeldatei: $!: $cfg\n";
while (<FILE>) {
	s/^\s+|\s+$//g; # Trim
	next if m/^;/; # Kommentare
	next if m/^$/; # Leerzeilen
	my ($cmd, $opt) = split /=/, $_;
	if (exists $cmds->{$cmd}) {
		print "ACT: $_\n" if $DBG;
		$cmds->{$cmd}->($opt);
	} else {
		print "IGN: $_\n" if $DBG;
	}
}
defined $out and close($out);
# Netz wird von selber abgebaut

Great utility, thanks for it! Now I can replace wine+qdriver...