← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libwww-perl/edgy

« back to all changes in this revision

Viewing changes to talk-to-ourself

  • Committer: Bazaar Package Importer
  • Author(s): Jay Bonci
  • Date: 2005-02-13 18:45:32 UTC
  • mfrom: (2.1.2 hoary)
  • Revision ID: james.westby@ubuntu.com-20050213184532-67qvopi4wre3010u
Tags: 5.803-4
http://bugs.debian.org/294597
http://bugs.debian.org/294595
* Make GET/POST/HEAD symlinks (Closes: #294597)
* lwp-requests now honors -b when dumping links (Closes: #294595)
  - Thanks to giuseppe bonacci for the patch
* Moved symlinks to a libwww-perl.links file

Show diffs side-by-side

added added

removed removed

Lines of Context:
talk-to-ourself
 
1
#!perl -w
 
2
 
 
3
# This program check if we are able to talk to ourself.  Misconfigured
 
4
# systems that can't talk to their own 'hostname' has the most commonly
 
5
# reported libwww-failure.
 
6
 
 
7
use strict;
 
8
require IO::Socket;
 
9
 
 
10
if (@ARGV >= 2 && $ARGV[0] eq "--port") {
 
11
    my $port = $ARGV[1];
 
12
    require Sys::Hostname;
 
13
    my $host = Sys::Hostname::hostname();
 
14
    if (my $socket = IO::Socket::INET->new(PeerAddr => "$host:$port", Timeout => 5)) {
 
15
        require IO::Select;
 
16
        if (IO::Select->new($socket)->can_read(1)) {
 
17
            my($n, $buf);
 
18
            if ($n = sysread($socket, $buf, 512)) {
 
19
                exit if $buf eq "Hi there!\n";
 
20
                die "Seems to be talking to the wrong server at $host:$port, got \"$buf\"\n";
 
21
            }
 
22
            elsif (defined $n) {
 
23
                die "Immediate EOF from server at $host:$port\n";
 
24
            }
 
25
            else {
 
26
                die "Can't read from server at $host:$port: $!";
 
27
            }
 
28
        }
 
29
        die "No response from server at $host:$port\n";
 
30
    }
 
31
    die "Can't connect: $@\n";
 
32
}
 
33
 
 
34
# server code
 
35
my $socket = IO::Socket::INET->new(Listen => 1, Timeout => 5);
 
36
my $port = $socket->sockport;
 
37
open(CLIENT, qq("$^X" "$0" --port $port |)) || die "Can't run $^X $0: $!\n";
 
38
 
 
39
if (my $client = $socket->accept) {
 
40
    print $client "Hi there!\n";
 
41
    close($client) || die "Can't close socket: $!";
 
42
}
 
43
else {
 
44
    warn "Test server timeout\n";
 
45
}
 
46
 
 
47
exit if close(CLIENT);
 
48
die "Can't wait for client: $!" if $!;
 
49
die "The can-we-talk-to-ourself test failed.\n";