Internet-Technologie Prof. Jürgen Plate

4 Client und Server programmieren

4.1 Netzwerk-Funktionen in Perl

Einige Perl-Funktionen verhalten sich anders als ihr äquivalen in C, obwohl sie dieselben Namen tragen. inet_aton ist nur ein Beispiel dafür. Ein anderes Beispiel ist accept(2), die in C einen Filedeskriptor oder -1 liefert, während in Perl eine spezielle Syntax für das neue Filehandle benutzt wird, und der Rückgabewert Information über den Kommunikationspartner enthält oder undef ist. (Diese Information wiederum kann man in C mit getpeername(2) erhalten.) sockaddr_in ist in C eine Struktur, in Perl eine Hilfsfunktion, die sowohl benutzt werden kann, um Daten aus dieser Struktur zu extrahieren, als auch um Daten in eine solche Struktur zu verfrachten.

IP-Adressen

($a,$b,$c,$d) = split(/\./, '192.168.34.3');
$packed_ip = pack('C4',$a,$b,$c,$d);

($a,$b,$c,$d) = unpack('C4',$packed_ip); 
$dotted_quad = join ('.', $a,$b,$c,$d); 

• $packed_ip = inet_aton($dotted_quad)
  Packen einer Adresse der Form 'a.b.c.d' in ein Binärformat wie es von sockaddr_in() gebraucht wird.

• $dotted_quad = inet_ntoa($packed_ip)
  Enpacken einer binär gespeicherten Adresse in das "lesbare" Format.

• $socket_addr = sockaddr_in($port,$address)
  ($port,$address) = sockaddr_in($socket_addr)
  Im skalaren Kontext (obere Zeile) wird eine Portnummer und eine binäre Adresse in einem Format geliefert, wie es die Methode socket benötigt. Im Listenkontext (untere Zeile) erfolgt die Konvertierung in umgekehrter Richtung.
  Wem das nicht gefällt, kann stattdessen $socket_addr = pack_sockaddr_in($port,$address) oder ($port,$address) = unpack_sockaddr_in($socket_addr) verwenden.

gethostbyaddr - Eintrag mit bestimmter IP ermitteln

1. die gewünschte IP-Adresse numerisch in binärer Schreibweise.
2. den Adresstyp der IP-Adresse (numerisch).

my $addr = inet_aton("127.0.0.1");
my $Wert  = gethostbyaddr($addr, AF_INET);
print "$Wert\n";

my $addr = inet_aton("127.0.0.1");
($name,$aliases,$atype,$len,$addrs) = gethostbyaddr($addr, AF_INET);
print "Name: $name\n";
print "Aliases: $aliases\n";
print "Adresse: ".join (".",unpack("C4", $addrs)), "\n";

gethostbyname - Eintrag mit bestimmtem Hostnamen ermitteln

Gibt die zugehörige IP-Adresse binär numerisch zurück. Im Listenkontext erhält man Name, Aliase, Addresstype, Länge und die Adresse.

my $addr  = gethostbyname("localhost");
my $Wert = inet_ntoa($addr);

my ($name,$aliases,$atype,$len,$addrs) = gethostbyname("menetekel");
print "Name: $name\n";
print "Aliases: $aliases\n";
print "Adresse: ".join (".",unpack("C4", $addrs)), "\n";

getnetbyaddr - Eintrag mit bestimmter IP ermitteln

1. die gewünschte IP-Adresse numerisch in binärer Schreibweise.
2. den Adresstyp der IP-Adresse (numerisch).

my $addr = inet_aton("127.0.0.0");
my $Wert  = getnetbyaddr($addr, AF_INET);

getnetbyname - Eintrag mit bestimmtem Netzwerknamen ermitteln

Gibt die zugehörige IP-Adresse binär numerisch zurück.

my $addr  = getnetbyname("loopback");
my $Wert = inet_ntoa($addr);

getprotobyname - Eintrag mit bestimmtem Protokollnamen ermitteln

Gibt die zugehörige Protokollnummer zurück. Wenn der übergebene Protokollname nicht gefunden wurde, wird undef zurückgegeben. Im Listenkontext erhält man Name, Aliase und Protokollnummer:

my $number = getprotobyname("tcp");
print "$number\n";

my ($name,$aliases,$number) = getprotobyname("tcp");
print "Name: $name\n";
print "Aliases: $aliases\n";
print "$number\n";

getprotobynumber - Eintrag mit bestimmter Protokollnummer ermitteln

Gibt den zugehörigen Protokollnamen zurück. Wenn die übergebene Protokollnummer nicht gefunden wurde, wird undef zurückgegeben. Im Listenkontext erhält man Name, Aliase und Protokollnummer:

my $number = getprotobynumber(17);
print "$number\n";

my ($name,$aliases,$number) = getprotobynumber(17);
print "Name: $name\n";
print "Aliases: $aliases\n";
print "$number\n";

getpwnam - Eintrag mit bestimmtem Benutzernamen ermitteln

Gibt im skalaren Kontext die zugehörige Benutzernummer (UID) und im Listenkontext eine Liste mit allen Daten des Eintrags zurück. Wenn der Benutzername nicht gefunden wurden, wird undef zurückgegeben.

print "\nUser-ID: ";
chop ($login = <STDIN>);

(@pw_info) = (getpwnam("$login"));
print "\nUserinformationen fuer login: $login\n\n";
print "Login: $pw_info[0]\n";
print "Pw (encoded): $pw_info[1]\n";
print "UserID: $pw_info[2]\n";
print "GroupID: $pw_info[3]\n";
print "Kommentar: $pw_info[6]\n";
print "HomeDir: $pw_info[7]\n";
print "Shell: $pw_info[8]\n";
print "\n\n";

getpwuid - Eintrag mit bestimmter Benutzernummer ermitteln

Gibt im skalaren Kontext den zugehörigen Benutzernamen und im Listenkontext eine Liste mit allen Daten des Eintrags zurück. Wenn die Benutzernummer nicht gefunden wurden, wird undef zurückgegeben.

print "\nUser-ID: ";
chop ($login = <STDIN>);

(@pw_info) = (getpwuid("$login"));
print "\nUserinformationen fuer login: $login\n\n";
print "Login: $pw_info[0]\n";
print "Pw (encoded): $pw_info[1]\n";
print "UserID: $pw_info[2]\n";
print "GroupID: $pw_info[3]\n";
print "Kommentar: $pw_info[6]\n";
print "HomeDir: $pw_info[7]\n";
print "Shell: $pw_info[8]\n";
print "\n\n";

getservbyname - Eintrag mit bestimmtem Portnamen ermitteln

1. den Namen des gewünschten Netzwerkdienstes,
2. den Namen des gewünschten Protokolls.

Gibt die zugehörige Portnummer zurück. Wenn der übergebene Netzwerkname oder das Protokoll nicht gefunden wurden, wird undef zurückgegeben. Im Listenkontext erhält man Name, Aliase, Port und Protokollnummer:

my $port = getservbyname("www","tcp");
print "$port\n";

my ($name,$aliases,$port,$number) = getservbyname("www","tcp");
print "Name: $name\n";
print "Aliases: $aliases\n";
print "Port: $port\n";
print "Proto: $number\n";

getservbyport - Eintrag mit bestimmter Portnummer ermitteln

1. die gewünschten Portnummer,
2. den Namen des gewünschten Protokolls.

my $port = getservbyport(80,"tcp");
print "$port\n";

my ($name,$aliases,$port,$number) = getservbyport(80,"tcp");
print "Name: $name\n";
print "Aliases: $aliases\n";
print "Port: $port\n";
print "Proto: $number\n";

IO::Socket::INET - die Socket-Schnittstelle

Konstruktor new( [ARGS] )

PeerAddr    Adresse des entfernten Hosts   <hostname>[:<port>]
PeerHost    Synonym für PeerAddr
PeerPort    Entfernter Port oder Dienst    <service>[(<no>)] | <no>
LocalAddr   Lokal gebundene Hostadresse    hostname[:port]
LocalHost   Synonym für LocalAddr
LocalPort   Lokal gebundener Host-Port     <service>[(<no>)] | <no>
Proto       Name/Nummer des Protokolls     "tcp" | "udp" | ...
Type        Socket-Typ                    SOCK_STREAM | SOCK_DGRAM | ...
Listen      Queue-Größe für Listen
Reuse       Setze SO_REUSEADDR vor Bindung.
Timeout     Timeout-Wert für verschiedene Operationen

$sock = IO::Socket::INET->new(PeerAddr => 'www.netzmafia.de',
                              PeerPort => 'http(80)',
                              Proto    => 'tcp');

$sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');

$sock = IO::Socket::INET->new(Listen    => 5,
                              LocalAddr => 'localhost',
                              LocalPort => 9000,
                              Proto     => 'tcp');

$sock = IO::Socket::INET->new('127.0.0.1:25');

Aktive Methoden

• $conn_sock = $listen_socket->accept()
  
• ($conn_sock,$remote_addr) = $listen_socket->accept()
  Diese Methode kann nur auf einen Socket im Zustand "listen", also bei einem Server, angewendet werden. Sie liefert für die nächste Anfrage aus der Warteschlange einen konnektierten Socket, der für die Kommunikation mit dem entfernten Host verwendet werden kann. Er erbt alle Eigenschaften des Server-Sockets. Im skalaren Kontext wird nur der konnektierte Socket geliefert, im Listenkontext zusätzlich die Adresse des entfernten Host im Binärformat.

• $sock->connect($port,$host)
  $sock->bind($port,$host)
  Im Gegensatz zu den gleichnamigen Methoden unten wird hier eine bequeme Möglichkeit geboten connect und bindmit Portnummer und der ungepackten Hostadresse (dotted quad oder symbolischer Hostname) aufzurufen.

• $sock->shutdown($how)
  Mit dieser Methode wird ein Socket geschlossen. shutdown() besitzt wesentlich höhere "Durchsetzungskraft" als close(). Es werden beispielsweise auch Sockets geschlossen, von denen offene Kopien in irgendwelchen Kindprozessen existieren. Der Parameter $how legt fest, was bei bidirektionalen Sockets geschlossen wird:
  0 : lesenden Socket schließen
  1 : schreibenden Socket schließen
  2 : Socket komplett schließen
  

• $wert = $sock->sockopt($option_name [,$option_wert])
  Socketoption erfragen oder setzen. Es handet sich um ein Frontend für getsockopt() oder setsockopt() aus dem Modul Socket. Mit einem einzigen (numerischen) Parameter aufgerufen, liefert die Methode den Wert der entsprechenden Option. Wird sie mit zwei Parametern aufgerufen, wird der Wert der entsprechenden Option neu gesetzt. In diesem Fall liefert die Methode einen Integer-Resultatwert, der über Erfolg oder Mißerfolg Auskunft gibt.

• $sock->send($data [,$flags,$destination])
  $sock->recv($data [,$flags,$destination])
  Frontend für die Funktionen send() und recv, die hauptsächlich für UDP-Verbindungen eingesetzt werden.

• $sock->connect($dest_addr)
  $sock->bind($my_addr)
  $sock->listen($max_queue)
  Diese Aufrufe werden selten verwendet, da sie bereits bei new intern aufgerufen werden oder komfortablere Varianten besitzen. Sie sind nur vorhanden, falls man die Einstellungen "von Hand" vornehmen will. Man kann z. B. auch so einen Socket erzeugen:

  $sock = IO::Socket::INET->new(Proto=>'tcp');
  $dest_addr = sockaddr_in(...); # usw.
  $sock->connect($dest_addr);
  

Informations-Methoden

• $sock->connected()
  liefert "wahr", falls der Socket eine Verbindung zum entfernten Rechner hat - verwendet peername().

• $sock->sockaddr()
  Gibt den Adreß-Teil der sockaddr-Struktur des Sockets zurück.

• $sock->sockport()
  Gibt die Portnummer zurück, die das Socket auf dem lokalen Host verwendet.

• $sock->sockhost()
  Gibt den Adreß-Teil der sockaddr-Struktur des Sockets in der Form "xx.xx.xx.xx" zurück.

• $sock->sockname()
  gibt nicht den Namen, sondern die gepackte Binäradresse des lokalen Hosts zurück.

• $sock->peeraddr()
  Gibt den Adreß-Teil der sockaddr-Struktur des Sockets auf dem entfernten Host zurück.

• $sock->peerport()
  Gibt die Portnummer des Sockets auf dem entfernten Host zurück.

• $sock->peerhost()
  Gibt den Adreß-Teil der sockaddr-Struktur des Sockets auf dem entfernten Host in der Form "xx.xx.xx.xx" zurück.

• $sock->peername()
  gibt nicht den Namen, sondern die gepackte Binäradresse des entfernten Hosts zurück.

• $sock->protocol()
  $sock->socktype()
  $sock->sockdomain
  liefern Basisinformationen über den entsprechenden Socket. Sie können nicht verwendet werden, um Eigenschaften des Socket zu ändern.

4.2 Single-Thread-Server und -Client in Perl

#!/usr/bin/perl
# tcp-server-st.pl -- Ein Single-threaded-TCP-Server

use strict;
use IO::Socket;

use constant MYPORT => 2000;
my $sock = '';
my $client = 0;

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";
print "Accepting connections on Port ", MYPORT, "...\n";

while ($client = $sock->accept()) 
  {
  # Eine Verbindung ist eingetroffen.
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Echo, das alles umdreht:
  while (<$client>) 
    {
    chomp;
    print $client scalar(reverse($_)), "\n";
    }
  $client->close() if defined $client;
  }

Der Client dazu kann auch zum Testen weiterer Demonstrations-Server verwendet werden. Hier ist die Parameterversorgung beim Erzeugen eines neuen Socket etwas anders. Die Adresse des zu kontaktierenden Servers und die Portnummer werden über die Kommandozeile eingegeben. Statt "Reuse" und "Listen" werden beim Client das Protokoll (TCP) und ein Timeoutwert übergeben. Der Client bricht somit nach 5 Sekunden ab, wenn keine Verbindung zustandekommt.
Der Client schickt alle Eingabezeilen zum Server. Falls zwischendurch Zeilen vom Server angekommen sind, werden Sie entgegengenommen und auf der Standardausgabe ausgegeben.

#!/usr/bin/perl
# tcp-client.pl -- Ein einfacher TCP-Client.
# Verwendung: $0 remote_host remote_port

use strict;
use IO::Socket;

use constant TIMEOUT => 5;
my $sock = '';
my $reply = '';

$sock = new IO::Socket::INET(PeerAddr => $ARGV[0],
			     PeerPort => $ARGV[1],
			     Proto    => 'tcp', Timeout => TIMEOUT)
    or die "can't connect to $ARGV[0]:$ARGV[1]: $@\n";

while (<STDIN>) 
  {
  print $sock $_;
  last unless defined($reply = <$sock>);
  print ">> $reply";
  }

$sock->close() if defined $sock;

4.3 Multi-Thread-Server und -Client in Perl

#!/usr/bin/perl
# tcp-server-mt.pl -- Ein Multithreaded-TCP-Server

use strict;
use IO::Socket;

use constant MYPORT => 2000;
my $sock = '';
my $client = '';

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";

# Zombies verhindern
$SIG{'CHLD'} = sub { wait();  $client ->close; };

print "Accepting connections on Port ", MYPORT, "...\n";
while ($client = $sock->accept()) 
  {
  # Verbindung ist aufgebaut
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Erzeugen eines Kindprozesses und Uebergabe an $client.
  if (fork() == 0) # Kindprozess 
    {
    # Echo, das alles umdreht:
    while (<$client>) 
      {
      chomp;
      print $client scalar(reverse($_)), "\n";
      }
    }
  }

Kommuniziert der erste Eigenbau-Client mit einem Server, der mehrere Zeilen zurückliefert, geht anscheinend irgendetwas schief. Der folgende Versuch, mit einem FTP-Server zu kommunizieren geht beim Login noch gut, aber danach wird die Kommunikation asynchron. Die Ausgaben des help-Befehls kommen nur Zeile für Zeile und man muß nach jeder Zeile die Enter-Taste drücken. Danach werden vom FTP-Server die leeren Eingaben mit einer Fehlermeldung quittiert:

plate@atlas:~/server > perl tcp-st-client.pl localhost 21
user plate
>> 331 Password required for plate.
pass Tralala
>> 230 User plate logged in.
help
>> 214-The following commands are recognized (* =>'s unimplemented).

>>    USER    PORT    STOR    MSAM*   RNTO    NLST    MKD     CDUP 

>>    PASS    PASV    APPE    MRSQ*   ABOR    SITE    XMKD    XCUP 

>>    ACCT*   TYPE    MLFL*   MRCP*   DELE    SYST    RMD     STOU 

>>    SMNT*   STRU    MAIL*   ALLO    CWD     STAT    XRMD    SIZE 

>>    REIN*   MODE    MSND*   REST    XCWD    HELP    PWD     MDTM 

>>    QUIT    RETR    MSOM*   RNFR    LIST    NOOP    XPWD 

>> 214 Direct comments to root@localhost.
quit
>> 500 '': command not understood.

>> 500 '': command not understood.

>> 500 '': command not understood.

>> 500 '': command not understood.

#!/usr/bin/perl
# tcp-mtclient.pl -- Ein multithreaded interaktiver TCP-Client.
# Verwendung: $0 remote_host remote_port

use strict;
use IO::Socket;

my $sock = '';

use constant TIMEOUT => 5;
$sock = new IO::Socket::INET(PeerAddr => $ARGV[0],
			     PeerPort => $ARGV[1],
			     Proto    => 'tcp', Timeout => TIMEOUT)
    or die "can't connect to $ARGV[0]:$ARGV[1]: $@\n";

# An dieser Stelle teilen wir mit fork() in zwei Prozesse auf:
if (fork()) # == 0 --> Kind
  {
  # Der Kindprozess: Server -> Mensch
  while (<$sock>) { print $_; }
  $sock->close() if defined $sock;
  die "server closed connection.\n";
  } 
else 
  {
  # Der Elternprozess: Mensch -> Server
  while (<STDIN>) { print $sock $_; }
  $sock->close();    # fertig, aufhaengen!
  wait();
  }

#!/usr/bin/perl

# Ein single-threaded interaktiver TCP-Client.
# Benutzt nur einen Prozess, aber IO::Select.
# Verwendung: $0 remote_host remote_port

use IO::Socket;
use IO::Select;
use strict;

my ($socket, $select, $handle);
my @ready = ();

$sock = new IO::Socket::INET(PeerAddr => $ARGV[0] 
                             PeerPort => $ARGV[1],
                             Proto    => 'tcp', 
                             Timeout  => 5)
    or die "can't connect to $ARGV[0]:$ARGV[1]: $@\n";

$select = IO::Select->new();

$select->add($sock);
$select->add(\*STDIN);

while (@ready = $select->can_read()) 
  {
  foreach $handle (@ready) 
    {
	last unless defined($reply = <$handle>);
	if ($handle == $sock) { print $reply; } 
	else                  { print $sock $reply; }
    }
  }
$sock->close();    # fertig, aufhaengen!

Der erste HTTP-Server

HTTP/1.0 404 Not Found
Server: Tralala 1.0
Content-Type: text/html
Connection: close

#!/usr/bin/perl
# Ein Mini-Webserver: Nur Fehlermeldung

use strict;
use IO::Socket;

use constant MYPORT => 8080;
my $sock = '';
my $client = '';

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";

print "Accepting connections on Port ", MYPORT, "...\n";
while ($client = $sock->accept()) 
  {
  # Verbindung ist aufgebaut
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Erzeugen eines Kindprozesses und Uebergabe an $client.
  if (fork() == 0) # Kindprozess 
    {
    $client->autoflush;
    my ($dummy);
    # Gaaaaaanz einfacher Webserver
    # Eingabe wird ignoriert, aber ausgegeben
    do
      {
      chomp($dummy = <$client>);
      print "$dummy\n";
      }
      while(length($dummy) > 1);
    print $client "HTTP/1.0 404 Not Found\n";
    print $client "Server: Tralala 1.0\n";
    print $client "Content-Type: text/html\n";
    print $client "Connection: close\n";
    print $client "\n";
    print $client "<html><head><title>404 Not Found</title></head>\n";
    print $client "<body><h1>404 Not Found</h1>\n";
    print $client "&Auml;tschib&auml;tsch!\n";
    print $client "</body></html>\n";
    print "*** FERTIG ***\n";
    $client ->close;
    }
  }

#!/usr/bin/perl
# Ein Mini-Webserver: Nur Fehlermeldung

use strict;
use IO::Socket;

use constant MYPORT => 8080;
my $sock = '';
my $client = '';

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";

$SIG{'CHLD'} = sub { wait(); };    # Zombies verhindern

print "Accepting connections on Port ", MYPORT, "...\n";
while ($client = $sock->accept()) 
  {
  # Verbindung ist aufgebaut
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Erzeugen eines Kindprozesses und Uebergabe an $client.
  if (fork() == 0) # Kindprozess 
    {
    $sock->close; # not needed in child
    $client->autoflush;
    my ($dummy);
    # Gaaaaaanz einfacher Webserver
    # Eingabe wird ignoriert, aber ausgegeben
    do
      {
      chomp($dummy = <$client>);
      print "$dummy\n";
      }
      while(length($dummy) > 1);
    print $client "HTTP/1.0 404 Not Found\n";
    print $client "Server: Tralala 1.0\n";
    print $client "Content-Type: text/html\n";
    print $client "Connection: close\n";
    print $client "\n";
    print $client "<html><head><title>404 Not Found</title></head>\n";
    print $client "<body><h1>404 Not Found</h1>\n";
    print $client "&Auml;tschib&auml;tsch!\n";
    print $client "</body></html>\n";
    print "*** FERTIG ***\n";
    $client ->close;
    }
  $client ->close; # not needed in parent   
  }

GET dateiname HTTP/1.x

#!/usr/bin/perl
# Ein Mini-Webserver - Dateiausgabe, aber nur Text

use strict;
use IO::Socket;

# Port waehlen
use constant MYPORT => 8080;

# Startdirectory (Server-Root) festlegen
my $startdir = '/home/plate/server/';
my $sock = '';
my $client = '';

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";

$SIG{'CHLD'} = sub { wait(); };    # Zombies verhindern

print "Accepting connections on Port ", MYPORT, "...\n";
while ($client = $sock->accept()) 
  {
  # Verbindung ist aufgebaut
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Erzeugen eines Kindprozesses und Uebergabe an $client.
  if (fork() == 0) # Kindprozess 
    {
    my ($input, $get, $file);
    $sock->close; # not needed in child
    $client->autoflush;
    # Gaaaaaanz einfacher Webserver
    # Eingabe wird untersucht und ausgegeben
    do
      {
      chomp($input = <$client>);
      print "$input\n";
      $get = $input if ($input =~ /GET/);
      }
      while(length($input) > 1);
    # Aus der GET-Zeile Dateinamen extrahieren
    $get =~ /GET ([^ ]*) HTTP/;
    $file= "$1";
    $file = $file . 'index.html' if ($file =~ /\/$/);
    $file =~ s/^\///g;          # '/' am Anfang weg
    $file =~ s/\.\.\///g;       # URLS der Form '../../' unterbinden
    $file = $startdir . $file;  # Server-Root davor setzen
    print "Senden $file\n";

    # Datei oeffnen und zum Client schicken.
    if (!open(DATEI,"$file"))
      {
      print $client "HTTP/1.0 404 Not Found\n";
      print $client "Server: Tralala 1.0\n";
      print $client "Content-Type: text/html\n";
      print $client "Connection: close\n";
      print $client "\n";
      print $client "<html><head><title>404 Not Found</title></head>\n";
      print $client "<body><h1>404 Not Found</h1>\n";
      print $client "</body></html>\n";
      print "*** FERTIG **\n";
      $client ->close;
      }
    else
      {
      print $client "HTTP/1.0 200 OK\n";
      print $client "Server: Tralala 1.0\n";
      print $client "Content-Type: text/html\n";
      print $client "Connection: close\n";
      print $client "\n";
      print $client $_ while(<DATEI>);
      close(DATEI);
      print "*** FERTIG **\n";
      $client ->close;
      }
    }
  $client ->close; # not needed in parent   
  }

Außerdem wird davon ausgegangen, daß die Kindprozesse in der Reichenfolge beendet werden, in der sie kreiert wurden, da sonst der einfache Signalhandler nicht funktioniert und wieder Zombies entstehen. Man muß also eine Prozeßverwaltung einrichten, wie es schon im vorhergehenden Kapitel gezeigt wurde. Einen Server, der dies macht, finden Sie bei den Beispielen als webserver3.pl.

Weitere Server

1. Sende "Ich will KEKSE".
2. Lies eine Zeile vom Client und prüfe sie auf das Wort "KEKSE".
3. Fall ja, sende "Mampf, Mampf...." und beende, andernfalls gehe zu 1.

#!/usr/bin/perl
# Keks-Monster

use strict;
use IO::Socket;

use constant MYPORT => 2300;
my $sock = '';
my $client = '';

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";

$SIG{'CHLD'} = sub { wait(); };    # Zombies verhindern

print "Accepting connections on Port ", MYPORT, "...\n";
while ($client = $sock->accept()) 
  {
  # Verbindung ist aufgebaut
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Erzeugen eines Kindprozesses und Uebergabe an $client.
  if (fork() == 0) # Kindprozess 
    {
    $sock->close; # not needed in child
    # Das Monster in Aktion
    print $client "Ich will KEKSE!\n";
    while (<$client>) 
      {
      chomp;
      if ($_ =~ /KEKSE/)
        {
        print $client "\nMampf, Mampf....\n\n";
        $client->close;
        }
      print $client "Ich will KEKSE!\n";
      }
    }
   $client->close; # not needed in parent
   }

Der folgende Server ist etwas anspruchsvoller. Er liefert, wie das UNIX-Programm fortune, einen mehr oder weniger coolen Spruch. Dazu wird das fortune-Programm in Perl nachempfunden. In der Datei /usr/share/fortune/fortunes stehen die meist mehrzeiligen Sprüche und sind jeweils durch eine Zeile getrennt, die nur ein %-Zeichen enthält. Deshalb wird beim Zugriff auf die Datei der Zeilentrenner mit $/ = "\n%\n" umdefiniert. So kann ein mehrzeiliger Text in eine skalare Stringvariable eingelesen und auf einmal an den Client gesendet werden. Nach der Ausgabe des Cookies wird die Verbindung sofort beendet.

#!/usr/bin/perl
# Fortune-Server

use strict;
use IO::Socket;

use constant MYPORT => 2000;
my $sock = '';
my $client = '';

$sock = new IO::Socket::INET(LocalPort => MYPORT,
		             Reuse     => 1,
		             Listen    => 5)
    or die "can't create local socket: $@\n";

$SIG{'CHLD'} = sub { wait(); };    # Zombies verhindern

print "Accepting connections on Port ", MYPORT, "...\n";
while ($client = $sock->accept()) 
  {
  # Verbindung ist aufgebaut
  print "Accepted connection from ",
        $client->peerhost(), ":", $client->peerport(), "\n";

  # Erzeugen eines Kindprozesses und Uebergabe an $client.
  if (fork() == 0) # Kindprozess 
    {
    $sock->close; # not needed in child
    # Jetzt kommt der Spruch
    $/ = "\n%\n";
    my ($data,$cookie);

    $data = '/usr/share/fortune/fortunes';
    srand($$);
    open(KEKS,"$data") || die "Keine Kekse\n";
    rand($.) < 1 && ($cookie = $_) while <KEKS>;
    $cookie =~ s/%$//;
    print $client "\n$cookie\n";
    close(KEKS);
    $client->close;
    }
   $client->close; # not needed in parent
   }

Ein Timeserver-Proxy

RFC 867 behandelt die Spezifikation des Protokolls "daytime", das sowohl über TCP/IP als auch über UDP auf dem Port 13 abgewickelt wird. Für die Syntax des zurückgegebenen Daytime-Strings gibt es keine allgemeinen Regeln, dieser String ist von Server zu Server unterschiedlich und kann beispielsweise das Format

Tag Monat Jahr Stunde:Minute:Sekunde

Das folgende Perl-Script liefert die Systemzeit des lokalen Rechners im Klartext.

#!/usr/bin/perl
# Ein einfacher Daytime-Server

use IO::Socket;

my $serversock = new IO::Socket::INET (
                   LocalPort => 13,
                   Listen    => $SOMAXCONN,
                   Proto     => 'tcp',
                   Reuse     => 1) || die "$!\n";

# In der Schleife auf eingehende Verbindungen warten... 
print "Accepting connections on Port 13...\n";

while (my $clientsock = $serversock->accept() ) 
  {
  my $cur_time = localtime(time);
  print $clientsock "$cur_time\n";
  $clientsock->close() if defined $clientsock;
  }

1. Aktuellen Binärwert holen und in eine "Perl-Zahl" entpacken.
2. Die Anzahl Sekunden zwischen 1.1.1970, 0 Uhr GMT und 1.1.1900, 0 Uhr GMT subtrahieren (das sind nach RFC 868 genau 2'208'988'800 Sekunden).
3. Das Ergebnis in einen Datumsstring für "Daytime" umwandeln.

Damit stellt dies Programm nicht mehr einen einfachen Server dar, sondern hat Proxy-Funktion. Es wird nicht nur die Anfrage an einen anderen Rechner weitergereicht, sondern auch zwei verschiedene (wenn auch sehr einfache) Protokolle implementiert. Da es sich trotz aller Einfacheit um höhere Protokolle handelt, wird hiermit auch das Prinzip eines Gateways demonstriert.

#!/usr/bin/perl
# Script baut eine Verbindung zum ausgewaehlten "Zeitserver" auf
# und liefert dann die genaue Uhrzeit an den Client

use IO::Socket;
use strict;

# Clientport und Serverport
use constant CLPORT => 13;
use constant SVPORT => 37;

# Differenz zwischen 1.1.1900 (Time-Server) 
# und 1.1.1970 (UNIX-Epoche)
use constant KORR => 2208988800;

# Mein Zeitserver
my $hostname = "ptbtime1.ptb.de"; # Timeserver der Physikalisch-Technischen
#       oder    ptbtime2.ptb.de   # Bundesanstalt in Braunschweig                                  

my $serversock = new IO::Socket::INET (
                   LocalPort => CLPORT,
                   Listen    => 5,
                   Proto     => 'tcp',
                   Reuse     => 1)
     or die "can't create local socket: $@\n";

# In der Schleife auf eingehende Verbindungen warten... 
print "Accepting connections on Port ", CLPORT, "...\n";

while (my $clientsock = $serversock->accept() ) 
  {
  my $cur_time = &get_time;
  print $clientsock "$cur_time\n";
  $clientsock->close() if defined $clientsock;
  }

# Zeit vom anderen Server holen
sub get_time
  {
  my ($binarytime, $servertime);
  my $ts_sock = new IO::Socket::INET (
                      PeerAddr => $hostname,
                      PeerPort => SVPORT,
                      Proto    => 'tcp')
       or die "can't create local socket: $@\n";

  read($ts_sock,$binarytime,4);
  $ts_sock->close();
  $servertime = unpack('N',$binarytime);
  $servertime = localtime($servertime - KORR);
  return "$servertime";
  }

Preforking

for (1..ANZ_PREFORK)
  {
  $child = fork();
  next if ($child != 0); # Elternprozess macht nix
  do_child($child);       # Ablauf Kindprozess
  exit(0);                # Ende Kindprozess
  }

sub do_child
  {
  my $socket = shift;
  my $connection_count = 0;
  while ($ch = $socket->accept())
    {
    handle_connection($ch);
    $ch->close();
    }
  }

Einen Dämon erzeugen

• das Rootverzeichnis als aktuelles Verzeichnis wählen, da der Start ja auch von einem unmountbarem Verzeichnis aus erfolgen könnte,
• umask auf einen bekannten Wert ändern,
• die PATH-Variable anpassen,
• Prozeß-ID in einer Datei in /var/run/ ablegen,
• gegebenenfalls Logging initialisieren (Logfile oder Syslog-Mechanismus),
• gegebenenfalls Signalhandler einrichten (z. B. HUP für einen Restart)
• gegebenenfalls Konfigurationsdatei einlesen und verarbeiten,
• gegebenenfalls User- und Gruppen-ID ändern (z. B. von root auf nobody),
• gegebenenfalls mit chroot() eine geschützte Umgebung schaffen.

#!/usr/bin/perl

$|=1;
use strict;

my ($pid, $i);

$pid = fork();
die "cannot fork: $!\n" if ($pid == -1);

# Parent beendet sich
if ($pid > 0)
  {
  print "Parent exits\n";
  exit(0);
  }

# Kindprozess wird von init adoptiert
chdir "/tmp" or die "could not chdir to /tmp: $!\n";

for($i = 0; $i < 100; $i++)
  {
  print "This is the Daemon.\n";
  sleep(5);
  }

Das folgende Unterprogramm erledigt einige weitere Aufgaben und eignet sich daher schon besser für den Praxiseinsatz. Die POSIX-kompatible Funktion setsid() kreiert jeweils neue neue Session- und Prozeß-Gruppe und macht den aktuellen Prozeß zum Session-Leader (wird an dieser Stelle nicht vertieft). Gleichzeitig wird der Prozeß komplett vom steuernden Terminal getrennt. Amschließend werden die Standarddateien wieder geöffnet, aber dabei auf /dev/null umgeleitet. So werden eventuelle Schreib- und Leseversuche von Subprozessen vernichtet. Man kann sie aber auch mittels close(\*STDIN); close(\*STDOUT); close(\*STDERR); komplett schließen.

use POSIX 'setsid';

sub become_daemon # ()
  {
  my $child = fork();
  unless (defined($child)) die "Cannot fork!\n";
  exit(0) if ($child > 0);      # Eltenprozess beendet sich
  make_pidfile(PIDFILE,$$);         # Pid-Datei anlegen (s. u.)
  setsid();                         # Abtrennen
  open(STDIN, "</dev/null");     # Standarddateien umlenken
  open(STDOUT, ">/dev/null");
  open(STDERR, ">&STDOUT");
  chdir('/');                       # Arbeitsverzeichnis /
  umask(0);                         # UMASK definieren
                                    # Pfad definiert setzen:
  $ENV{PATH} = '/bin; /sbin; /usr/bin; /usr/sbin;';
  return $$;
  }

kill -TERM `cat /var/run/server.pid`

sub make_pidfile # (dateiname, newpid)
  {
  my $filename = shift;
  my $newpid = shift;
  if (-e $filename)  # Datei schon vorhanden
    {
    open PID "<$filename";
    my $pid = <PID>;
    close PID;
    # gibt's den Server noch?
    die "Server already running ($pid)\n" if kill 0 => $pid;
    # Hier ggf. noch nachsehen, ob der Prozess auch ein alter
    # Serverprozess ist und nicht zufaellig ein anderer Prozess
    # diese Prozessnummer besitzt
    # Nun die alte Datei platt machen
    unlink $filename || die "Cannot delete $filename\n";
    }
  # Neue Datei anlegen und Zugriffsrechte setzen
  open PID ">$filename";
  print PID $newpid;
  close PID;
  chmod(644 $filename);
  }

# Namen der PID-Datei festlegen
use constant PIDFILE => '/var/run/myserver.pid';

# Exit-Handler setzen
$SIG{TERM} = $SIG{INT} = sub { exit 0; }

# Daemon werden
my $daemonpid = become_daemon();

# Sicherstellen, dass beim Exit die PID-Datei 
# auf jeden Fall geloescht wird
# (Der Elternprozess muss die Datei aber in Ruhe lassen)
END { unlink(PIDFILE) if ($daemonpid == $$); }

Benutzer- und Gruppen-ID ändern

• $<   Reale User-ID des Prozesses (numerisch)
• $(   Reale Gruppen-ID des Prozesses (numerisch)
• $>   Effektive User-ID des Prozesses (numerisch)
• $)   Effektive Gruppen-ID des Prozesses (numerisch)

Analog lassen sich auch die Gruppenrechte verändern. Ist der Benutzer in mehreren Gruppen vertreten, enthalten die Variablen $) und $( eine Liste der Gruppen-IDs, jeweils durch Leerzeichen getrennt. Für den Wechsel der "primary group" wird ein einziger Wert an die Variable $( zugewiesen. Um die effektive Gruppen-ID zu wechseln, wird ein einziger Wert in $) gespeichert. Wird eine Liste von (durch Leerzeichen getrennten) Gruppen-IDs an $) zugewiesen, wird die erste Zahl zur effektiven Gruppen-ID und die folgenden zu den "supplementary groups". Besteht die Liste aus nur zweimal demselben Wert, hat der Prozeß nur noch eine einzige Gruppen-ID.

Protokollierung

• Verwendung des Syslog-Mechanismus
  Unter UNIX gibt es den Syslog-Daemon, der Nachrichten per Prozeßkommunikation (UNIX Domain Socket) entgegennimmt und im Standard-Logfile speichert. Perl erlaubt die komfortable Syslog-Nutzung mit Hilfe des Pakets Sys::Syslog, auf das an dieser Stelle nicht weiter eingegangen wird.
• Schreiben in eine Log-Datei
  Eine einfache Alternative zum Syslog ist das führen einer eigenen Logdatei, die - wie andere Logfiles - unterhalb von /var/log beheimatet sein sollte. Eine eigene Log-Datei gestattet auch eine einfache statistische Auswertung, da nur Einträge eines einzigen Serverdienstes in der Datei stehen und der Programmierer frei im Aufbau eines Eintrags ist. Das einzige Problem taucht auf, wenn es ggf. mehrere Kondprozesse gibt, die alle in dieselbe Log-Datei schreiben wollen und dies auch noch gleichzeitig. Dafür stellt Perl aber einen einfachen Filelocking-Mechanismus zur Verfügung. Für die Dauer des Schreibvorgangs kann die Datei mit der Funktion flock() für andere Zugriffe gesperrt und später wieder freigegeben werden. Die Syntax lautet $boolean = flock(FILEHANDLE, $how);, wobei $how den Modus enthält:

  Wert	Name	Beschreibung
  1	LOCK_SH	Shared Lock
  2	LOCK_EX	Exclusive Lock
  4	LOCK_NB	Non-Blocking Lock
  8	LOCK_UN	Unlock (Freigabe)

Netterweise erlaubt uns Perl auch die Umleitung der Standardfunktionen die und warn, sie lassen sich also im Programm weiterhin verwenden, nur daß jetzt der Output im Logfile landet. Das ist besonders dann interessant, wenn man nachträglich Logging hinzufügt.

Für das Logging sind nur wenige Unterprogramme nötig:

• start_log($dateiname): Öffnet die die Datei (append) und leitet die und warn um.
• log_info($message): gibt eine informative Nachricht ins Logfile aus.
• log_warn($message): gibt eine Warnung (Fehlermeldung) ins Logfile aus.
• log_die($message): gibt eine Fehlermeldung ins Logfile aus und beendet den Prozeß.
• end_log: schliesst die Logdatei.

use strict;

sub start_log #(Dateiname)
  {
  my $filename = shift;
  open(FH,">>".$filename) || return 0;
  chmod($filename,644);
  # Autoflush setzen fuer FH
  my $oldfh = select(FH); $| = 1; select($oldfh);
  # Lock freigeben
  flock(FH,8);
  # warn und die umleiten
  $SIG{__WARN__} = \&log_warn;
  $SIG{__DIE__} = \&log_die;
  return 1;
  }

sub end_log
  {
  close(FH);
  }

sub log_info #(Message)
  {
  my $time = localtime;
  my $mesg = join(' ',@_) || "Oops!";
  $mesg = $time . " [INFO] " . $mesg . "\n";
  flock(FH,2);
  print FH $mesg;
  flock(FH,8);
  }

sub log_warn #(Message)
  {
  my $time = localtime;
  my $mesg = join(' ',@_) || "Oops!";
  $mesg = $time . " [ERROR] " . $mesg . "\n";
  flock(FH,2);
  print FH $mesg;
  flock(FH,8);
  }

sub log_die #(Message)
  {
  my $time = localtime;
  my $mesg = join(' ',@_) || "Oops!";
  $mesg = $time . " [FATAL] " . $mesg . "\n";
  flock(FH,2);
  print FH $mesg;
  flock(FH,8);
  close(FH);
  die @_;
  }

Timeouts abfangen

#!/usr/bin/perl

use strict;

# Signalhandler setzen
$SIG{"ALRM"} = sub { print "Timeout - terminated!\n"; exit(1); };

# Timeout nach 10 Sekunden
alarm(10);

# Damit was passiert
my $count = 0;
while (1)
  {
  $count++;
  print "Rumpelstilzchen $count!\n";
  sleep(1);
  }

4.4 Perl-Clients für Standard-Dienste

Client für Binärdaten

	
#!/usr/bin/perl
# Ein einfacher TCP-Client zum Abspielen von mp3-Dateien
# Verwendung: $0 URL

use strict;
use IO::Socket;

use constant TIMEOUT => 5;
my $SOCK = '';
my $reply = '';
my $content = ''; 
my $header = '';

my $handler = '/usr/bin/audioplay';                # Abspielprogramm

my $url = shift @ARGV;                             # URL zerlegen
$url=~m/http\:\/\/([^\:^\/]*)(?:\:(\d+))?\/(.*)/;
my $host = $1;
my $port = $2;
$port = 80 unless($port);
my $file = '/'.$3;

$SOCK = new IO::Socket::INET(PeerAddr => $ARGV[0],
			     PeerPort => $ARGV[1],
			     Proto    => 'tcp', Timeout => TIMEOUT)
    or die "can't connect to $ARGV[0]:$ARGV[1]: $@\n";

my $old_fh = select(SOCK);                         # Ungepufferte Ausgabe 
$|=1;                                              # fuer SOCK einstellen
select($old_fh);

print "Requesting $file..\n";
print SOCK "GET $file HTTP/1.0\n";
print SOCK "Accept: */*\n";
print SOCK "User-Agent: webamp 007\n\n";
print "Waiting for reply..\n";
$header = <SOCK>;
exit unless($header=~m/200|OK/);                   # Ende bei Fehlermeldung
while($header = <SOCK>)                            # Header ueberlesen
  {
  chomp;
  last unless(m/\S/);
  }
open(HANDLER, "|$handler") or die "Cannot pipe input to $handler: $!\n";
print "Redirecting HTTP filestream to $handler..\n";
while(read(SOCK, $content, 512))
  {
  print HANDLER $content;                          # Perl-Strings sind
  }                                                # "binaerfest"
$sock->close() if defined $sock;

Portscanner

#!/usr/bin/perl -w

use IO::Socket;
use strict;     

my $pinghost = '';
$|=1;

foreach $pinghost (@ARGV)
  {
  &port_scan($pinghost, 1, 1024);
  }
exit;   


sub port_scan  # ($hostip, $lowport, $highport)
  {
  my $port = 0;
  my $iaddr = 0;
  my $paddr = 0;
  my $connect_time = 1;
  my $protocol_name = "tcp";
  my $protocol_id = getprotobyname($protocol_name);
  my $hostip = shift;
  my $lowport = shift;
  my $highport = shift;


  print "Portscan von $hostip.\n";
  for ($port = $lowport; $port <= $highport; $port++) 
    {
    $SIG{"ALRM"} = sub { close(SOCKET); };
    alarm $connect_time;
  
    socket(SOCKET, PF_INET, SOCK_STREAM, $protocol_id);

    $iaddr  = inet_aton($hostip);
    $paddr  = sockaddr_in($port, $iaddr);   
        
    print "  Port $port offen.\n" if (connect(SOCKET, $paddr));
    close(SOCKET); 
    }
  }

FTP-Clients

• new (HOST [,OPTIONS])
  ist der Constructor für ein Net::FTP-Objekt. HOST spezifiziert den FTP-Server, mit Verbindung aufgenommen werden soll. Dieser Parameter muß angegeben werden. Optionen werden in einer Hash-ähnlichen Schreibweise in OPTIONS übergeben. Mögliche Werte sind u. a.:
  • Timeout: Die maximale Zeit in Sekunden, die gewartet wird, bis der Server antwortet (Voreinstellung: 120 Sekunden).
  • Port: Die Nummer des Ports des FTP-Servers, zu dem die Verbindung aufgenommen werden soll. Voreinstellung: 21.
  • Debug: Ermöglicht Diagnosemeldungen auf STDERR (Voreinstellung: false).
  • Passive: Falls true werden Datentransfers im "passive mode" ausgeführt. Einige Proxy-Konfigurationen erfordern diesen Modus. Dieser Wert wird durch die Umgebungsvariable FTP_PASSIVE überschrieben.
  • Hash: Falls true werden Doppelkreuze (#), sog. Hashmarks, während des Transfers auf STDERR ausgegeben.
  Im Fehlerfall wird undef zurückgegeben und eine Fehlermeldung in $@ gesetzt. Beispiel:

  #!/usr/bin/perl -w
  
  use Net::FTP;
  use strict;     
  
  my $host = 'ftp.netzmafia.de';
  
  my $ftp = Net::FTP->new ($host,
                          Timeout => 360,
                          Port    => 21,
                          Debug   => 1,
                          Hash    => 0
                         );
  
  unless (defined $ftp) 
    {
    print "$@\n";
    die "Can't create Net::FTP-Object\n";
    }
  

  Erzeugen eines neuen FTP Objekts, das mit der Addresse des FTP Servers initialisiert wird. Gleichzeitig wird die Verbindung mit dem FTP Server hergestellt. Dieses "Verbindungsobjekt" wird nun über seinen Namen ($ftp) angesprochen. NNun kann es nun mittels passender Methoden manipuliert bzw. verwendet werden werden. Genau dies geschieht in den folgenden Skriptzeilen:
  Man loggt sich ein mittels Benutzernamen und Paßwort, lädt eine Datei herunter oder hinauf und loggt sich wieder aus.
• login ([USER [,PASSWORD [, ACCOUNT] ] ])
  Führt den Login-Prozess auf dem FTP-Server mit den angegebenen Informationen (Username, Passwort, etc.) durch. Werden keine Argumente angegeben, verwendet Net::FTP das Modul Net::Netrc zur Ermittlung dieser Daten. Falls keine Information in der Datei .netrc gefunden wird, wird ein anonymer Login ausgeführt. In diesem Fall wird bei Fehlen des Passworts die E-Mail-Adresse des lokalen Users verwendet. Beispiel:

  $user = 'plate';
  $password = 'geheim';
  $ftp->login($user,$password) || die "Can't login $!";
  

  oder unter Verwendung von .netrc:

  $ftp->login(); # Sucht einen passenden Eintrag in .netrc für HOST aus new()
  

  Anonymer Login:

  $ftp->login('anonym','webhamster@netzmafia.de');
  

• site (ARGS)
  Sendet das FTP-Kommando SITE mit dem gegebenen Argument und wartet auf die Antwort des Servers. Zurückgegeben wird das erste Digit des Antwortcodes; zum Beispiel:

  $return_code = $ftp->site("chmod 755 $file");
  

  Das erste Digit hat gemäss RFC 959 folgende Bedeutung
  • 1yz Positive Preliminary reply
  • 2yz Positive Completion reply
  • 3yz Positive Intermediate reply
  • 4yz Transient Negative Completion reply
  • 5yz Permanent Negative Completion reply

  Mögliche Fehlerbehandlung:

  print "Kommando O.K. - Datentransfer\n" if ($return_code == 1);
  print "Kommando erfolgreich\n"          if ($return_code == 2);
  print "Kommando O.K. - Weiter!\n"       if ($return_code == 3);
  print "Temporaerer Fehler\n"            if ($return_code == 4);
  print "Fehler \n"                       if ($return_code == 5);
  

• type (TYPE)
  Setzt den Typ der Datenübertragung. Zurückgegeben wird der vorherige Typ. Net::FTP verwendet folgende Synonyme um den Typ zu spezifzieren:

     ascii  => A
     binary => I
     ebcdic => E
     byte   => L
  

  Beispiel:

  # ascii-transfer
  $ftp->type("A");
  
  # binaer-transfer
  $ftp->type("I");
  

  ebcdic und byte werden nicht vollständig unterstützt.
• rename (OLDNAME, NEWNAME)
  benennt die Datei OLDNAME in NEWNAME auf dem FTP-Server um. Zum Umbennen von Dateien auf dem lokalen Rechner steht Ihnen die Perlfunktion rename() zur Verfügung (rename($old_name,$new_name);) Beispiel (Datei auf dem FTP-Server umbenennen):

  $old_name = 'test.txt';
  $new_name = 'Protokoll.txt';
  
  $ftp->rename($old_name,$new_name) || die "Can't rename\n";
  

• delete (FILENAME)
  Löscht die angegebene Datei auf dem FTP-Server. Zum Löschen von Dateien auf dem lokalen Rechner steht Ihnen die Perlfunktion unlink($file) zur Verfügung. Beispiel:

  $ftp->delete($file) || die "Can't unlink remote $file $!";
  

• cwd ([DIR])
  change working directory. Wechselt in das angegebene Verzeichnis auf dem FTP-Server. Falls DIR nicht spezifiziert ist, wird ins Wurzelverzeichnis gewechselt. Beispiel:

  $dir = '/pub/perl/CPAN/';
  $ftp->cwd($dir) || die "Can't change working directory $dir $!";
  

• cdup ()
  change directory up. Wechselt in das übergeordnete Verzeichnis auf dem FTP-Server. Beispiel:

  $ftp->cdup();
  

• pwd ()
  print working directory. Gibt den Namen des aktuellen Verzeichnisses auf dem FTP-Server zurück. Beispiel:

  print "Aktuelles Verzeichnis: ", $ftp->pwd() , "\n";
  

• rmdir (DIR [,RECURSE])
  Löscht das Verzeichnis DIR auf dem FTP-Server. Zum Löschen von Verzeichnissen auf dem lokalen Server können Sie die Perlfunktion rmdir() verwenden. Falls RECURSE auf "wahr" gesetzt wird, werden alle angegebenen Verzeichnisse rekursiv gelöscht. Beispiel:

  $dir = 'temp_files';
  
  $OK = $ftp->rmdir($dir,0);
  

• mkdir (DIR [,RECURSE])
  Erstellt das Verzeichnis DIR auf dem FTP-Server und gibt den Pfad zum neu angelegten Verzeichnis zurück. Zum Erstellen von Verzeichnissen auf dem lokalen Server können Sie die Perlfunktion mkdir() verwenden. Beispiel:

  $dir = '/pub/foo';
  
  $path = $ftp->mkdir($dir) || die "Can't create remote $dir $!";
  print "$path\n";
  

  Falls RECURSE auf "wahr" gesetzt wird, werden alle angegebenen Verzeichnisse rekursiv angelegt, zum Beispiel:

  $dir = '/pub/perl/new-files';
  $ftp->mkdir($dir,1) || die "Can't create remote $dir recursively $!";
  

  erzeugt die Verzeichnisse /pub und /pub/perl und /pub/perl/new-files.
• ls ([DIR])
  Liefert das Directory-Listing für DIR oder (ohne Parameter) das aktuelle Verzichnis auf dem FTP-Server zurück. Je nach Kontext wird eine Liste oder eine Referenz auf eine Liste mit Dateinamen zurückgegeben. Beispiel für Listenkontext:

  @files = $ftp->ls();
  foreach $file (@files) 
    {
    print "$file\n";
    }
  

  Beispiel für skalalen Kontext:

  $array_ref = $ftp->ls();
  foreach $file (@$array_ref) 
    {
    print "$file\n";
    }
  

  Die meisten FTP-Server verwenden das Unix-Kommando ls oder etwas dazu analoges.
• dir ([DIR])
  Wie ls(). Es wird jedoch das lange Format (Zugriffsrechte, Eigentümer, Datum, Dateigrösse, etc.) verwendet. Die meisten FTP-Server dafür das Unix-Kommando ls -l.
• get (REMOTE_FILE [,LOCAL_FILE [,WHERE]])
  holt die Datei REMOTE_FILE vom FTP-Server. Falls keine Name für die lokale Datei angegeben wird, erhält sie dien Namen von REMOTE_FILE. WHERE spezifiziert die Anzahl Bytes der Datei, die beim Transfer übersprungen werden sollen. Dies ist sinnvoll, wenn ein unterbrochener Dateitransfer vervollständigt werden soll. Beispiel für das Holen eines kompletten Verzeichnisses:

  @files = $ftp->ls();
  foreach $file (@files) 
    {
    $ftp->get($file);
    }
  

  Hinweis: Falls die Datei(en) im ASCII-Modus übertragen wurden, können sich die Grössenangaben bzw. Startpunkte auf dem lokalen Server und dem FTP-Server unterscheiden (Unterschiede bei der Darstellung des Zeilenendes).
• put (LOCAL_FILE [,REMOTE_FILE])
  Transferiert die Datei LOCAL_FILE zum FTP-Server. Falls es sich bei LOCAL_FILE um ein Dateihandle handelt, muß REMOTE_FILE angegeben werden. Ist REMOTE_FILE nicht spezifiziert, wird der Name der lokalen Datei verwendet. Zurückgeben wird der Name (ohne Verzeichnis) der Datei auf dem FTP-Server. Beispiel:

  $file = '/home/plate/foo.bar';
  $remote_file_name = $ftp->put($file) || die "Can't put $file $!";
  print "$remote_file_name\n";	# ergibt foo.bar
  

• supported (CMD)
  Gibt "wahr" zurück, falls der FTP-Server das angegebene Kommando akzeptiert. Beispiel:

  $OK = $ftp->supported('STOU');
  $OK ? print "STOU supported\n" : "STOU is not supported\n";
  

• abort()
  Unterbricht den augenblicklichen Datentransfer. Beispiel:

  $OK = $ftp->abort();
  

• quit()
  Sendet das Kommando QUIT an den FTP-Server und schliesst die Socketverbindung. Beispiel:

  $ftp->quit();
  

#!/bin/perl

use Net::FTP;
use strict;

my $host = 'localhost';
my $user = 'plate';
my $password = 'geheim';
my $file = '';
my $array_ref = '';

# Neues Net::FTP-Objekt
my $ftp = Net::FTP->new($host,
                        Timeout => 360,
                        Debug   => 1
                       );
unless (defined $ftp) 
  {
  print "$@\n";
  die "Can't create Net::FTP-Object\n";
  }

$ftp->login($user,$password) || die "Can't login $!";
print "Aktuelles Verzeichnis: ", $ftp->pwd() , "\n";

$array_ref = $ftp->ls();
foreach $file (@$array_ref) 
  {
  # Transfermodus in Abhängigkeit von der Dateiendung setzen
  if ($file =~ /(\.gif|\.jpg|\.tar|\.tar\.gz|\.tgz|\.zip)$/)
    { $ftp->type(I); } 
  else { $ftp->type(A); }
  $ftp->get($file); 
  }

$ftp->quit();

Ping

1. UDP: Net::Ping schickt ein UDP-Packet an den echo-Port des gewünschten Rechners. Falls das gesendete Datagramm mit dem zurückgeliefertem übereinstimmt, gilt der Rechner als erreichbar.
2. TCP: Net::Ping versucht eine TCP-Verbindung zum echo-Port des gewünschten Rechners aufzubauen. Im Erfolgsfall gilt der Rechner als erreichbar.
3. icmp: Net::Ping sendet eine icmp-Nachricht an den gewünschten Rechner. Falls gesendete und empfangene Daten übereinstimmen gilt der Rechner als erreichbar. Das Programm muß in diesem Fall unter der von root laufen.

• new([PROTO [,TIMEOUT [, BYTES]]])
  Der Constructor für ein neues Net::Ping-Objekt. Alle Parameter sind optional. PROTO spezifiziert das zu verwendende Protokoll. Mögliche Werte sind: tcp, udp (Voreinstellung) oder icmp. Net::Ping verwendet intern die Funktion alarm(), wenn das Protokoll tcpverwendet wird. Falls in Ihrem Programm bereits ein Alarm gesetzt ist, wird dieser überschrieben.
  TIMEOUT setzt die Timeoutzeitspanne in Sekunden. Voreinstellung: 5 Sekunden. Dieser Wert wird für die Methode ping() verwendet.
  BYTES spezifiziert die Anzahl Bytes, die für die ping-Anfrage verwendet werden sollen. Dieser Wert wird ignoriert, wenn TCP verwendet wird. Voreinstellung: UDP: 1, ICMP: 0.

• ping(HOST [, TIMEOUT])
  pingt die entfernte Maschine HOST. Falls die Maschine erreichbar ist, wird "wahr" zurückgegeben. Falls der Host nicht gefunden werden kann, wird undef zurückgegeben. In der Praxis sollten Sie 'undef' und 'false' als identisch betrachten. Beispiel:

  if ( $p->ping($host) ) 
    { print "$host is reachable\n"; } 
  else { print "$host is unreachable\n"; }
  

• close()
  Schließt die Netzwerkverbindung. Die Verbindung wird ebenfalls geschlossen, wenn der Scope verlassen wird. Beispiel:

  $p->close();
  

• pingecho(HOST [, TIMEOUT])
  Veraltet. Existiert aus Kompatibilitätsgründen zu älteren Versionen.

sub pinger # (Host)
  {
  # Parameter: Host-IP-Nummer
  my $host = shift;         # zu pingender Host
  my $retval = 0;           # Ergebnis: 0 nicht erreicht, 1 erreicht, 2 Fehler
  # Neues Net-Ping Objekt
  my $p = Net::Ping->new('icmp');
  unless (defined $p) 
    { die "*** can't create Net::Ping object $!";}

  # Exceptions auffangen
  eval 
    {
    $retval = 1 if ($p->ping($host)); 
    if ($@) 
      {
      print "*** Ping failed\n*** $@\n";
      $retval = 2;
      }
    $p->close;
    undef ($p);
    sleep(1);       # avoid network flooding
    return $retval;
    }
  }

#!/usr/bin/perl -w

use Net::Ping;
use strict;	

my $network = '192.168.33';

print "Scanning Network $network.0 \n";
for ($count = 1; $count <= 254; $count++)
  {
  $pinghost = $network . "." . $count;
  $ret = &pinger($pinghost);
  if ($ret == 1)
    { print "$pinghost reached\n"; }
  }

 exit;

#!/usr/bin/perl -w

use Net::Ping; 		# Standardmodul
use strict;	

my $host = '127.0.0.1';

# Protokoll TCP
my $p = Net::Ping->new('tcp');
unless (defined $p) { die "can't create Net::Ping object $!";}

if ($p->ping($host)) { print "$host reachable via TCP\n" ; }
else                 { print "$host unreachable via TCP\n"; }
$p->close;

# avoid network flooding
sleep(1);

# Protokoll UDP

$p = Net::Ping->new(); # UDP ist Voreinstellung
unless (defined $p) { die "can't create Net::Ping object $!";}

# Exceptions auffangen
eval 
  {
  if ($p->ping($host)) { print "$host reachable via UDP\n"; }
  else { print "$host unreachable via UDP\n"; }
  };

if ($@) { print "$@: UDP failed\n"; }
undef $p;

# avoid network flooding
sleep(1);


if ($> == 0) 
  {
  # Falls das Skript als 'root' (UID 0) läuft
  # Protokoll 'icmp' verwenden
  $p = Net::Ping->new('icmp');

  unless (defined $p) { die "can't create Net::Ping object $!";}

  if ($p->ping($host)) { print "$host reachable via icmp\n"; }
  else { print "$host unreachable via icmp\n"; }
  undef $p;
  }

exit;	

Webapplikationen

1. UserAgent-Objekt
2. URI
3. Request-Objekt
4. Response-Objekt

# UserAgent
use LWP::UserAgent;
$ua = LWP::UserAgent->new();
	
# URI 
$url = 'http://www.netzmafia.de/';

# Request
$Anfrage  = HTTP::Request->new('GET', $url);	

# Response
$Antwort = $ua->request($Anfrage);

unless ($Antwort->is_success() ) 
  { 
  print "Fehlernummer : ", $Antwort->code() , "\n";
  print "Fehlermeldung: ", $Antwort->message(), "\n";
  }

HTTP-Header

use LWP::Simple;

$url = "http://www.netzmafia.de/index.html";

# Header ermitteln
($content_type, $document_length, $modified_time, $expires, $server) = head($url);

# Ergebnisse ausgeben
print "Content-type:    ", $content_type,       "\n";
print "Document-Length: ", $document_length,    "\n";
print "Modified-Time:   ", $modified_time,      "\n";
print "Expires:         ", $expires,            "\n";
print "Server:          ", $server,             "\n";

$exists = head($url);
if ($exists) { print "URI existiert\n"; }
else { print "\a\a\aKein Anschluss unter dieser URI.\n"; }

LWP::Simple

1. get zum Holen eines Dokuments, z. B.:

   use LWP::Simple;
   $url = 'http://www.netzmafia.de/index.html'
   $dokument = get($url);
   unless (defined $dokument) { print "ERROR\n"; exit };
   

2. getprint, um das ganze Dokument zu holen und den Inhalt auszugeben:

   use LWP::Simple;
   $url = 'http://www.netzmafia.de/index.html'
   getprint($url);
   

3. getstore, um das ganze Dokument zu holen und in einer Datei zu speichern:

   use LWP::Simple;
   $url = 'http://www.netzmafia.de/index.html'
   $localfile = '/home/plate/tmp/index.html';
   getstore($url, $localfile);
   

LWP::UserAgent

#!/usr/bin/perl -w

use LWP::UserAgent;
use strict;

my ($url, $ua, $request, $response);

$url = "http://www.netzmafia.de/index.html";

# User Agent
$ua = LWP::UserAgent->new();

# Anfrage mit Methode HEAD
$request = HTTP::Request->new('HEAD', $url);

# Antwort holen	
$response = $ua->request($request);

if ($response->is_success()) 
  {
  # Header als ASCII-Text ausgeben
  print $response->headers_as_string() , "\n"
  }
else
  {
  # Fehlermeldung ausgeben
  print $response->message() , "\n";
  }

...
$size = $response->header('Content-Length');
print "URL: $url  Grösse: $size Bytes\n";
...

#!/usr/bin/perl -w

use LWP::UserAgent;
use strict;

my ($url, $ua, $request, $response);

$url = "http://192.168.33.2/index.html";

# User Agent
$ua = LWP::UserAgent->new();

$request = HTTP::Request->new('HEAD', $url);
$response = $ua->request($request);

print "HTTP-Status-Antwort-Header: ", $response->code , "\n";

• Tag: 86400 s
• Woche: 604800 s
• Monat (30,5 Tage): 2635200 s
• Jahr (365 Tage): 31536000 s

use HTTP::Status;
use HTTP::Date;
use LWP::UserAgent;
use strict;

my ($url, $ua, $request, $response);

$url = 'http://192.168.33.2/';

$request = HTTP::Request->new(HEAD, $url );

# Tag               =>    86400 s
# Woche (7 Tage)    =>   604800 s
# Monat (30.5 Tage) =>  2635200 s
# Jahr  (365 Tage)  => 31536000 s  

# Aktuelle Zeit in UnixSekunden - 1 Tag = gestern
$mtime = time -  86400; 

# Request-Header setzen
$request->header('If-Modified-Since' => time2str($mtime));
	
# User Agent
$ua = LWP::UserAgent->new();

$response = $ua->request($req);

# 304 --> Keine Aenderung seit der angefragten Zeitspanne
if ( $response->code() == RC_NOT_MODIFIED) 
  { print "$url wurde seit time2str($mtime) nicht geändert\n"; } 
else { print "\aWake up. $url changed\n"; }

Die Methode response() von LWP::UserAgent bietet einen komfortablen Zugriff auf Dokumente. Neben der verbesserten Möglichkeit zur Erfolgskontrolle stehen drei Varianten zur Verfügung.

1. response($request)
   holt das angeforderte Dokument. Der Inhalt des Dokumentes ist über die Methode content() erreichbar.

   use LWP::UserAgent;
   
   $ua = LWP::UserAgent->new();
   $url = 'http://www.netzmafia.de/'
   $request = HTTP::Request->new('GET', $url);
   
   $response = $ua->request($request);
   if ( $response->is_error() ) 
     { 
     print "Fehlernummer : ", $response->code() ,    "\n";
     print "Fehlermeldung: ", $response->message() , "\n";
     }
   else 
     {
     print $response->content() , "\n";
     }
   

2. response($request, $file)
   holt das ageforderte Dokument und speichert den Inhalt in der angegeben lokalen Datei.

   use LWP::UserAgent;
   
   $file = 'local.html';
   $ua = LWP::UserAgent->new();
   $url = 'http://www.netzmafia.de/'
   $request = HTTP::Request->new('GET', $url);
   
   $response = $ua->request($request, $file);
   if ( $response->is_error() ) 
     { 
     print "Fehlernummer : ", $response->code() ,    "\n";
     print "Fehlermeldung: ", $response->message() , "\n";
     }
   else 
     {
     print $response->content() , "\n";
     }
   

3. response($request, \&callback, $Chunk_Size)
   holt das angeforderte Dokument häppchenweise. Die Grösse der Happen wird mit $Chunk_Size festgelegt. Nach dem Erhalt eines jeden Pakets wird dieses Paket an eine Callbackroutine weitergereicht, die bereits während der Übertragung die angekommenen Daten verarbeiten kann.

   use LWP::UserAgent;
   
   $file = 'local.html';
   $ua = LWP::UserAgent->new();
   $url = 'http://www.netzmafia.de/'
   $request = HTTP::Request->new('GET', $url);
   
   $Chunk_Size = 5 * 1024; # Wie gross soll der Happen sein
   
   $response = $ua->request($request, \&Bearbeite, $Chunk_Size);
   
   sub Bearbeite 
     {
     $Bereits_erhaltene_Daten = shift;
   
     ...
     ++$x;
     print "Happen Nummer $x\n\n";
     print "$Bereits_erhaltene_Daten\n";
     ...
     }
   

   Diese Vorgehensweise ist beispielsweise sinnvoll bei
   • langsamen Netzverbindungen
   • umfangreichen Downloads (Datei muß nicht in den Hauptspeicher passen)
   • Hintergrundverarbeitung des Inhalts
   • Parsen des Dokuments schon während der Übertragung
   • Extrahieren von Links
   • Verarbeitung des Inhaltes in einem separatem Prozess
   • Verarbeitung kontinuierlicher Datenströme

Zugriff auf WWW-Formulare mit GET

use LWP::UserAgent;

$ua = LWP::UserAgent->new();
$url = http://www.netzmafia.de/cgi-bin/info.cgi?Category=Soft&Language=Perl

$request = HTTP::Request->new('GET', $url);

$response = $ua->request($request);
if ( $response->is_error() ) 
  { 
  print "Fehlernummer : ", $response->code() ,    "\n";
  print "Fehlermeldung: ", $response->message() , "\n";
  }
else 
  {
  print $response->content() , "\n";
  }

Falls die Daten des Query-Strings Leerzeichen, Sonderzeichen oder ähnliche kritische Zeichen enthalten, müssen diese entsprechend kodiert werden. Das Modul URI::Escape stellt die dafür notwendigen Methoden zur Verfügung:

use URI::Escape;

$querystring = 'Name=Jürgen Plate&Strasse=Gänsemarkt 5';
$safe_querystring = uri_escape($querystring);
print $safe_querystring , "\n";

$querystring = 'Name=Jürgen Plate&Strasse=Gänsemarkt 5';
$safe_querystring = uri_escape($querystring);
$url = 'http://www.netzmafia.de/cgi-bin/info.cgi?';
$url .= "$safe_querystring";
...

$request = HTTP::Request->new('GET', $url);
...

Zum vorhergehenden Abschnitt

Zum Inhaltsverzeichnis

Zum nächsten Abschnitt

Copyright © FH München, FB 04, Prof. Jürgen Plate