← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/memcached/jaunty

« back to all changes in this revision

Viewing changes to t/lib/MemcachedTest.pm

  • Committer: Bazaar Package Importer
  • Author(s): Jay Bonci
  • Date: 2007-05-02 11:35:42 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20070502113542-qpoxsq28fjb7s9wc
Tags: 1.2.1-1
http://bugs.debian.org/405054
http://bugs.debian.org/417941
http://bugs.debian.org/383660
http://bugs.debian.org/391351
* New upstream release (Closes: #405054)
* Fix to logfile output so logrotate will work (Closes: #417941)
* Listen in on localhost by default (Closes: #383660)
* Default configuration suggests nobody by default (Closes: #391351)
* Bumped policy version to 3.7.2.2 (No other changes)

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/lib/MemcachedTest.pm
 
1
package MemcachedTest;
 
2
use strict;
 
3
use IO::Socket::INET;
 
4
use Exporter 'import';
 
5
use FindBin qw($Bin);
 
6
use Carp qw(croak);
 
7
use vars qw(@EXPORT);
 
8
 
 
9
@EXPORT = qw(new_memcached sleep mem_get_is mem_stats free_port);
 
10
 
 
11
sub sleep {
 
12
    my $n = shift;
 
13
    select undef, undef, undef, $n;
 
14
}
 
15
 
 
16
sub mem_stats {
 
17
    my ($sock, $type) = @_;
 
18
    $type = $type ? " $type" : "";
 
19
    print $sock "stats$type\r\n";
 
20
    my $stats = {};
 
21
    while (<$sock>) {
 
22
        last if /^(\.|END)/;
 
23
        /^STAT (\S+) (\d+)/;
 
24
        #print " slabs: $_";
 
25
        $stats->{$1} = $2;
 
26
    }
 
27
    return $stats;
 
28
}
 
29
 
 
30
sub mem_get_is {
 
31
    # works on single-line values only.  no newlines in value.
 
32
    my ($sock_opts, $key, $val, $msg) = @_;
 
33
    my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
 
34
    my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
 
35
 
 
36
    my $expect_flags = $opts->{flags} || 0;
 
37
    my $dval = defined $val ? "'$val'" : "<undef>";
 
38
    $msg ||= "$key == $dval";
 
39
 
 
40
    print $sock "get $key\r\n";
 
41
    if (! defined $val) {
 
42
        my $line = scalar <$sock>;
 
43
        if ($line =~ /^VALUE/) {
 
44
            $line .= scalar(<$sock>) . scalar(<$sock>);
 
45
        }
 
46
        Test::More::is($line, "END\r\n", $msg);
 
47
    } else {
 
48
        my $len = length($val);
 
49
        my $body = scalar(<$sock>);
 
50
        my $expected = "VALUE $key $expect_flags $len\r\n$val\r\nEND\r\n";
 
51
        if (!$body || $body =~ /^END/) {
 
52
            Test::More::is($body, $expected, $msg);
 
53
            return;
 
54
        }
 
55
        $body .= scalar(<$sock>) . scalar(<$sock>);
 
56
        Test::More::is($body, $expected, $msg);
 
57
    }
 
58
}
 
59
 
 
60
sub free_port {
 
61
    my $type = shift || "tcp";
 
62
    my $sock;
 
63
    my $port;
 
64
    while (!$sock) {
 
65
        $port = int(rand(20000)) + 30000;
 
66
        $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
 
67
                                      LocalPort => $port,
 
68
                                      Proto     => $type,
 
69
                                      ReuseAddr => 1);
 
70
    }
 
71
    return $port;
 
72
}
 
73
 
 
74
sub supports_udp {
 
75
    my $output = `$Bin/../memcached-debug -h`;
 
76
    return 0 if $output =~ /^memcached 1\.1\./;
 
77
    return 1;
 
78
}
 
79
 
 
80
sub new_memcached {
 
81
    my $args = shift || "";
 
82
    my $port = free_port();
 
83
    my $udpport = free_port("udp");
 
84
    $args .= " -p $port";
 
85
    if (supports_udp()) {
 
86
        $args .= " -U $udpport";
 
87
    }
 
88
    if ($< == 0) {
 
89
        $args .= " -u root";
 
90
    }
 
91
    my $childpid = fork();
 
92
 
 
93
    my $exe = "$Bin/../memcached-debug";
 
94
    croak("memcached binary doesn't exist.  Haven't run 'make' ?\n") unless -e $exe;
 
95
    croak("memcached binary not executable\n") unless -x _;
 
96
 
 
97
    unless ($childpid) {
 
98
        exec "$exe $args";
 
99
        exit; # never gets here.
 
100
    }
 
101
 
 
102
    for (1..20) {
 
103
        my $conn = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
 
104
        if ($conn) {
 
105
            return Memcached::Handle->new(pid  => $childpid,
 
106
                                          conn => $conn,
 
107
                                          udpport => $udpport,
 
108
                                          port => $port);
 
109
        }
 
110
        select undef, undef, undef, 0.10;
 
111
    }
 
112
    croak("Failed to startup/connect to memcached server.");
 
113
 
 
114
}
 
115
 
 
116
############################################################################
 
117
package Memcached::Handle;
 
118
sub new {
 
119
    my ($class, %params) = @_;
 
120
    return bless \%params, $class;
 
121
}
 
122
 
 
123
sub DESTROY {
 
124
    my $self = shift;
 
125
    kill 9, $self->{pid};
 
126
}
 
127
 
 
128
sub port { $_[0]{port} }
 
129
sub udpport { $_[0]{udpport} }
 
130
 
 
131
sub sock {
 
132
    my $self = shift;
 
133
    return $self->{conn} if $self->{conn} && getpeername($self->{conn});
 
134
    return $self->new_sock;
 
135
}
 
136
 
 
137
sub new_sock {
 
138
    my $self = shift;
 
139
    return IO::Socket::INET->new(PeerAddr => "127.0.0.1:$self->{port}");
 
140
}
 
141
 
 
142
sub new_udp_sock {
 
143
    my $self = shift;
 
144
    return IO::Socket::INET->new(PeerAddr => '127.0.0.1',
 
145
                                 PeerPort => $self->{udpport},
 
146
                                 Proto    => 'udp',
 
147
                                 LocalAddr => '127.0.0.1',
 
148
                                 LocalPort => MemcachedTest::free_port('udp'),
 
149
                                 );
 
150
 
 
151
}
 
152
 
 
153
1;