Logo VB-EDV-Beratung

VbModem

Die Klasse VbModem dient als High-Level-Schnittstelle für serielle Verbindungen z.B. über ein Modem. Sie setzt auf dem Modul Term::Readkey auf und stellt Funktionen für das Öffnen und Verriegeln der Verbindung, das Warten auf bestimmte Strings, ein Äquivalent des UNIX-Kommandos chat sowie Routinen für die Protokollierung zur Verfügung.

VbModem steht in einem eigenen Package und benötigt noch einige andere Module. Die Variable $buffer enthält die aus der Schnittstelle gelesenen Zeichen, die Variable @buffer alle Antworten eines chat.

package VbModem;
require IO::File;
use Term::ReadKey;
use POSIX qw(strftime);
use FileHandle;

$buffer = "";
@buffer = ();

Hier wird die neue Klassen-Variable mit ihren Eigenschaften erzeugt und 'gesegnet'.

sub new {
    my $class = shift;
    my $me = {};
    $me->{infile} = new IO::File;
    $me->{outfile} = new IO::File;
    $me->{open} = 0;
    bless($me,$class);
}

lock($) versucht ein Locking gemäß der UUCP-Konventionen zu erreichen. Es braucht normalerweise nicht vom Anwendungsprogrammierer aufgerufen zu werden, da es bereits von open($$) benutzt wird. Im Fehlerfalle wird ein die mit einer Fehlermeldung ausgelöst.

unlock($) gibt das Lock wieder frei.

sub lock($) {
    my $me = shift;
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."lock   $name\n")
        if exists($me->{logname});
    my ($name) = ($me->{devname} =~ /^.*\/([^\/]*)$/);
    my $lockname = "/var/lock/LCK..$name";
    my $file = new IO::File;
    if (-f $lockname){
        print "Lockfile $lockname existiert\n" if defined $me->{debug};
        $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."lock   ".
            "$name existiert\n") if exists($me->{logname});
        $file->open("<$lockname") or die "can't open $lockname: $!";
        $pid = int(<$file>);
        $file->close;
        die "Prozeß $pid hat $me->{devname} gelockt (kill)." if kill(0,$pid);
        die "Prozeß $pid hat $me->{devname} gelockt (errno)." if $! != ESRCH;
        unlink $lockname;
        $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."lock   ".
            "$name gelöscht\n") if exists($me->{logname});
    }
    my $oldumask = umask 0000;
    $file->open($lockname,O_WRONLY|O_CREAT|O_TRUNC|O_EXCL,0444)
        or die "$lockname: $!";
    umask $oldumask;
    $me->{lockname} = $lockname;
    printf $file "%10d\n",$$;
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."locked $name\n")
        if exists($me->{logname});
}

sub unlock ($){
    my $me = shift;
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."unlock $name\n")
        if exists($me->{logname});
    unlink $me->{lockname} if ($me->{open} && $me->{lockname});
    undef $me->{lockname};
}

open($$) erhält als Parameter (neben der Referenz auf sich selbst) den Namen der zu benutzenden Schnittstelle. Vor diese wird ein '/dev/' gestellt, wenn er keine Slashes ('/') enthält.

close($) schließt die Verbindung wieder und entfernt mit unlock($) das Lock.

sub open($$){
    my ($me,$name) = @_;
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."open   $name\n")
        if exists($me->{logname});
    $name = "/dev/".$name unless $name =~ /\//;
    $me->{devname} = $name;
    $me->lock();
    print "gelockt\n" if defined $me->{debug};
    $me->{infile}->open("<".$name) || die "$name (in): $!";
    $me->{outfile}->open(">".$name) || die "$name (out): $!";
    print "geöffnet\n" if defined $me->{debug};
    $me->{open} = 1;
    select $me->{outfile}; $| = 1; select STDOUT;
    ReadMode 5,$me->{infile};
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."opened $name\n")
        if exists($me->{logname});
}

sub close($){
    my $me = shift;
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."close  $name\n")
        if exists($me->{logname});
    if ($me->{open}){
        ReadMode 0, $me->{infile};
        $me->{infile}->close || die "closing $me->{devname} (in): $!";
        $me->{outfile}->close || die "closing $me->{devname} (out): $!";
    }
    $me->unlock();
    $me->{open} = 0;
    $me->logPrint(strftime("%d.%m.%Y  %H:%M:%S  ",localtime)."closed $name\n")
        if exists($me->{logname});
}

print($;$) und printf($;$) geben, wie ihre bekannten Namensvettern, Text auf die Schnittstelle aus.

sub print($;$) {
    my ($me,@what) = @_;
    die "print: $!" unless print {$me->{outfile}} @what;
    $me->logPrint('>'.join('',@what).'>') if exists($me->{logname});
}

sub printf($;$) {
    my ($me,@what) = @_;
    die "printf: $!" unless printf {$me->{outfile}} @what;
    $me->logPrint('>'.sprintf(@what).'>') if exists($me->{logname});
}

ReadUntil($$;$) wartet eine vorgegebene Zeit darauf, daß im eingehenden Datenstrom einer der übergeben Strings auftaucht. Ist dies der Fall wird der Index des Strings +1 zurückgegeben. Wenn nicht der Wert 0.

sub ReadUntil ($$;$){
    my ($me,$timeout,@words) = @_;
    my ($secs,$char);
    my $stop = time() + $timeout;
    $buffer = "";
    while (1){
        $secs = $stop - time();
        last if $secs < 1;
        $char = ReadKey($secs,$me->{infile});
        last if !defined $char;
        $buffer .= $char;
        $me->{terminal}->print($char) if defined $me->{terminal};
        my $i = 0;
        for (@words){
            $i++;
            if (index($buffer,$_) >= 0){
                print "ReadUntil:$i\n$buffer\n" if defined $me->{debug};
                $me->logPrint("<$buffer<") if exists($me->{logname});
                return wantarray ? ($i,$buffer) : $i;
            }
        }
    }
    $me->logPrint("<$buffer<") if exists($me->{logname});
    print "ReadUntil:0\n$buffer\n" if defined $me->{debug};
    return wantarray ? (0,$buffer) : 0;
}

chat($$;$) ist angelehnt an das UNIX-Kommando chat, das eine Reihe von Strings erhält, die abwechselnd erwartet bzw. ausgegeben werden. Im Fehlerfalle bricht der die des ReadUntil($$;$) die Routine ab.

sub chat ($$;$){
    my ($me,$timeout,@chat) = @_;
    my ($i);
    my $expect = 1;
    @buffer = ();
    for (@chat){
        if ($expect){
            if (length($_)){
                $me->ReadUntil($timeout,$_) or
                    die "kann '$_' nicht lesen";
                push(@buffer,$buffer);
            }
        } else {
            print ">$_\n" if defined $me->{debug};
            $me->print($_);
        }
        $expect = !$expect;
    }
}

DESTROY soll als Notanker das Lock entfernen.

sub DESTROY{
    my $me = shift;
    $me->unlock();
}

Die Methoden termAttach($$) und termDetach($) hängen ein Objekt einer Terminal-Klasse (z.B. meine Klasse vt100) in den Eingangs-Datenstrom, so daß dort ein Abbild eines Bildschirm mitgeführt werden kann.

sub termAttach($$) {
    my ($me,$term) = @_;
    $me->{terminal} = $term;
}

sub termDetach($) {
    my ($me) = @_;
    $me->{terminal} = undef;
}

lofTo($$) und logStop sorgen dafür, daß alle Ein- und Ausgaben in einer Datei mitprotokolliert werden bzw. dieses Log abgeschaltet wird.

logPrint($$) gibt den übergebenen String im Log-File aus.

sub logTo($$){
    my($me,$name) = @_;
    $me->{logname} = $name;
}

sub logPrint($$){
    my($me,$text) = @_;
    return if !exists($me->{logname});
    $log = new FileHandle;
    open($log,">>$me->{logname}") || return;
    print $log $text;
    close($log);
}

sub logStop($){
    my($me) = @_;
    delete $me->{logname};
}

1;

Und hier gibt's VbModem.pm nochmal im Stück.

© 2003 Volker Böhm Best viewed with any Browser Valid HTML 4.0