xref: /dports/net-im/p5-DJabberd/DJabberd-0.85/t/lib/djabberd-test.pl

BEGIN {
    $ENV{LOGLEVEL} ||= "WARN";
    use DJabberd::Log;
    DJabberd::Log->set_logger();
}
use strict;
use DJabberd;
use DJabberd::Authen::AllowedUsers;
use DJabberd::Authen::StaticPassword;
use DJabberd::TestSAXHandler;
use DJabberd::RosterStorage::InMemoryOnly;
use DJabberd::Util;
use IO::Socket::UNIX;

my $HAS_SASL;
eval "use Authen::SASL 2.1402";
unless ($@) {
    require DJabberd::SASL::AuthenSASL;
    $HAS_SASL = 1;
}

sub once_logged_in {
    my $cb = shift;
    my $sasl = shift;
    my $server = Test::DJabberd::Server->new(id => 1);
    $server->start;
    my $pa = Test::DJabberd::Client->new(server => $server, name => "partya");
    if ($sasl) {
        $pa->sasl_login($sasl);
    }
    else {
        $pa->login;
    }
    $cb->($pa);
    $server->kill;
}

sub two_parties {
    my $cb = shift;

    if ($ENV{WILDFIRE_S2S}) {
        two_parties_wildfire_to_local($cb);
        return;
    }

    if ($ENV{WILDFIRE_TEST}) {
        two_parties_one_wildfire($cb);
        return;
    }

    two_parties_one_server($cb);
    sleep 1;
    two_parties_s2s($cb);
    sleep 1;
}

sub two_parties_one_wildfire {
    my $cb = shift;

    my $wf = Test::DJabberd::Server->new(id => 1,
                                         type => 'wildfire',
                                         clientport => 5222,
                                         serverport => 5269,
                                         hostname => 's2.example.com',
                                         connect_ip => '24.232.168.187',
                                         not_local => 1,
                                         );
    $wf->start;
    my $pa = Test::DJabberd::Client->new(server => $wf, name => "partya");
    my $pb = Test::DJabberd::Client->new(server => $wf, name => "partyb");

    $pa->create_fresh_account;
    $pb->create_fresh_account;

    $cb->($pa, $pb);

}

sub two_parties_wildfire_to_local {
    my $cb = shift;

    my $wf = Test::DJabberd::Server->new(id => 2,
                                         type => 'wildfire',
                                         clientport => 5222,
                                         serverport => 5269,
                                         hostname => 's2.example.com',
                                         connect_ip => '24.232.168.187',
                                         not_local => 1,
                                         );
    $wf->start;
    my $pa = Test::DJabberd::Client->new(server => $wf, name => "partya");
    $pa->create_fresh_account;

    my $server1 = Test::DJabberd::Server->new(id => 1);
    $server1->link_with($wf);
    my $pb = Test::DJabberd::Client->new(server => $server1, name => "partyb");

    $cb->($pa, $pb);
}

sub two_parties_one_server {
    my $cb = shift;

    my $server = Test::DJabberd::Server->new(id => 1);
    $server->start;

    my $pa = Test::DJabberd::Client->new(server => $server, name => "partya");
    my $pb = Test::DJabberd::Client->new(server => $server, name => "partyb");
    $cb->($pa, $pb);

    $server->kill;
}

sub two_parties_s2s {
    my $cb = shift;

    my $server1 = Test::DJabberd::Server->new(id => 1);
    my $server2 = Test::DJabberd::Server->new(id => 2);
    $server1->link_with($server2);
    $server2->link_with($server1);
    $server1->start;
    $server2->start;

    my $pa = Test::DJabberd::Client->new(server => $server1, name => "partya");
    my $pb = Test::DJabberd::Client->new(server => $server2, name => "partyb");
    $cb->($pa, $pb);

    $server1->kill;
    $server2->kill;
}

sub two_parties_cluster {
    my $cb = shift;

    my $server1 = Test::DJabberd::Server->new(id => 1);
    my $server2 = Test::DJabberd::Server->new(id => 2);
    # TODO: configure these to know about each other.
    $server1->start;
    $server2->start;

    my $pa = Test::DJabberd::Client->new(server => $server1, name => "partya");
    my $pb = Test::DJabberd::Client->new(server => $server2, name => "partyb");
    $cb->($pa, $pb);

    $server1->kill;
    $server2->kill;
}

sub test_responses {
    my ($client, %map) = @_;
    my $n = values %map;
    # TODO: timeout on recv_xml_obj and die if don't get 'em all
    my @stanzas;
    my $verbose = ($ENV{LOGLEVEL} || "") eq "DEBUG";
    for (1..$n) {
        warn "Reading stanza $_/$n...\n" if $verbose;
        push @stanzas, $client->recv_xml_obj;
        warn "Got stanza: " . $stanzas[-1]->as_xml . "\n" if $verbose;
    }

    my %unmatched = %map;
  STANZA:
    foreach my $s (@stanzas) {
        foreach my $k (keys %unmatched) {
            my $tester = $map{$k};
            my $okay = eval { $tester->($s, $s->as_xml); };
            if ($okay) {
                Test::More::pass("matched response '$k'");
                delete $unmatched{$k};
                next STANZA;
            }
        }
        Carp::croak("Didn't match stanza: " . $s->as_xml);
    }

}

package Test::DJabberd::Server;
use strict;
use overload
    '""' => \&as_string;

use Data::Dumper    qw[Dumper];
local $Data::Dumper::Indent = 1;

our $PLUGIN_CB;
our $VHOST_CB;
our @SUBDOMAINS;

sub as_string {
    my $self = shift;
    return $self->hostname;
}

sub new {
    my $class = shift;
    my $self = bless {@_}, $class;

    die 'ID required. Pass it as ->new(id => $id)' unless $self->{id};
    return $self;
}

sub peeraddr {
    my $self = shift;
    return $self->{connect_ip} || ($self->{not_local} ? $self->{hostname} : "127.0.0.1");
}

sub serverport {
    my $self = shift;
    return $self->{serverport} || "1100$self->{id}";
}

sub clientport {
    my $self = shift;
    return $self->{clientport} || "1000$self->{id}";
}

sub adminport {
    my $self = shift;
    return $self->{adminport} || 0;
}

sub id {
    my $self = shift;
    return $self->{id};
}

sub hostname {
    my $self = shift;
    return $self->{hostname} || "s$self->{id}.example.com";
}

sub link_with {
    my ($self, $other) = @_;
    push @{$self->{peers}}, $other;
}

sub roster_name {
    my $self = shift;
    use FindBin qw($Bin);
    return "$Bin/t-roster-$self->{id}.sqlite";
}

sub roster {
    my $self = shift;
    my $roster = $self->roster_name;

    # We need to clear the cache so we can really unlink it, kind of ghetto
    my $dbh = DBI->connect("dbi:SQLite:dbname=$roster","","", { RaiseError => 1, PrintError => 0, AutoCommit => 1 });
    my $CachedKids_hashref = $dbh->{Driver}->{CachedKids};
    %$CachedKids_hashref = () if $CachedKids_hashref;
    unlink $roster;
    return $roster;
}

sub standard_plugins {
    my $self = shift;
    my @sasl;
    @sasl = ( DJabberd::SASL::AuthenSASL->new(
                mechanisms => "LOGIN PLAIN DIGEST-MD5",
                optional   => "yes",
            )) if $HAS_SASL;
    return [
            DJabberd::Authen::AllowedUsers->new(policy => "deny",
                                                allowedusers => [qw(partya partyb)]),
            DJabberd::Authen::StaticPassword->new(password => "password"),
            DJabberd::RosterStorage::InMemoryOnly->new(),
            ($ENV{T_MUC_ENABLE} ? (DJabberd::Plugin::MUC->new(subdomain => 'conference')) : ()),
            DJabberd::Delivery::Local->new,
            DJabberd::Delivery::S2S->new,
            @sasl
            ];
}

sub std_plugins_sans_sasl {
    my $self = shift;
    return [ grep { ref($_) !~ /SASL/ } @{ $self->standard_plugins }  ];
}

sub start {
    my $self = shift;
    my $type = $self->{type} || "djabberd";

    if ($type eq "djabberd") {
        my $plugins = shift || ($PLUGIN_CB ? $PLUGIN_CB->($self) : $self->standard_plugins);
        my $vhost = DJabberd::VHost->new(
                                         server_name => $self->hostname,
                                         s2s         => 1,
                                         plugins     => $plugins,
                                         );
        my $server = DJabberd->new;
        $server->set_config_unixdomainsocket($self->{unixdomainsocket}) if $self->{unixdomainsocket};

        foreach my $peer (@{$self->{peers} || []}){
            $server->set_fake_s2s_peer($peer->hostname => DJabberd::IPEndPoint->new($peer->peeraddr, $peer->serverport));
            foreach my $subdomain (@SUBDOMAINS) {
                $server->set_fake_s2s_peer($subdomain . '.' . $peer->hostname => DJabberd::IPEndPoint->new("127.0.0.1", $peer->serverport));
            }
        }

        $VHOST_CB->($vhost) if $VHOST_CB;

        $server->add_vhost($vhost);
        $server->set_config_serverport($self->serverport);
        $server->set_config_clientport($self->clientport);
        $server->set_config_adminport($self->adminport) if $self->adminport;

        if( my $server_callback = shift ){
          $server_callback->($server);
        }

        my $childpid = fork;
        if (!$childpid) {
            unless ($ENV{TESTDEBUG}) {
                ## no spurious output unless debugging
                close(STDIN);
                close(STDOUT);
                close(STDERR);
                open(STDIN,  "+>/dev/null");
                open(STDOUT, "+>&STDIN");
                open(STDERR, "+>&STDIN");
            }
            $server->run;
            exit 0;
        }

        $self->{pid} = $childpid;
    }

    if ($type eq "wildfire") {
        #...
    }

    return $self;
}

sub kill {
    my $self = shift;
    if ($self->{pid}) {
        CORE::kill(9, $self->{pid});
        my $pid = delete $self->{pid};
        local $?; # we don't want to inherit the waited pid's exit status
        waitpid $pid, 0;
    }
}

sub DESTROY {
    my $self = shift;
    $self->kill;
}

package Test::DJabberd::Client;
use MIME::Base64;
use strict;

use overload
    '""' => \&as_string;

use Data::Dumper    qw[Dumper];
local $Data::Dumper::Indent = 1;

sub resource {
    return $_[0]{resource} ||= ($ENV{UNICODE_RESOURCE} ? "test\xe2\x80\x99s computer" : "testsuite_with_gibberish:'\"");
}

sub username {
    my $self = shift;
    return $self->{name};
}

sub password {
    my $self = shift;
    return $self->{password} || "password";
}

sub as_string {
    my $self = shift;
    return $self->username . '@' . $self->{server}->hostname;
}

sub server {
    my $self = shift;
    return $self->{server};
}

sub new {
    my $class = shift;
    my $self = bless {@_}, $class;
    $self->{events} = [];
    $self->{readbuf} = '';
    die unless $self->{name};
    return $self;
}

sub get_event {
    my ($self, $timeout, $midstream) = @_;
    $timeout ||= 10;

    my $handler = DJabberd::TestSAXHandler->new($self->{events});
    my $parser = DJabberd::XMLParser->new( Handler => $handler );
    if ($midstream) {
        $parser->parse_more("<stream:stream xmlns:stream='http://etherx.jabber.org/streams' xmlns='jabber:client'>");
        pop @{$self->{events}};
    }

    my $undef = sub {
        my $why = shift;
        $parser->finish_push;
        #warn "Returning undef because: $why\n";
        return undef;
    };

    #$| = 1;
    #print "going to read...\n";

    my $get_byte;
    $get_byte = sub {
        if (length $self->{readbuf}) {
            my $byte = substr($self->{readbuf}, 0, 1, '');
            return $byte;
        }

        my $byte;
        my $rin = '';
        vec($rin, fileno($self->{sock}), 1) = 1;
        my $n = select($rin, undef, undef, $timeout)
            or return $undef->("select timeout");

        IO::Handle::blocking($self->{sock}, 0);
        my $rv = sysread($self->{sock}, $self->{readbuf}, 4096);
        IO::Handle::blocking($self->{sock}, 1);
        if (!$rv) {
            return $undef->("sysread no return");
        }
        $get_byte->();
    };

    while (! @{$self->{events}}) {
        my $byte = $get_byte->();
        return undef unless defined $byte;
        $parser->parse_more($byte);
    }
    my $ev = shift @{$self->{events}};
    #print "\ngot event: [$ev]\n";
    #if (UNIVERSAL::isa($ev, "DJabberd::XMLElement")) {
    #    print "  looks like: " . $ev->as_xml . "\n";
    #}

    $parser->finish_push;
    $handler->{on_end_capture} = undef;

    return $ev;
}

# if using $timeout, you're declaring that you can expect nothing and
# undef is returned.  otherwise must return XML.  (or die after 10 seconds)
sub recv_xml {
    my ($self, $timeout) = @_;
    my $ev = $self->get_event($timeout, 1);
    return undef if $timeout && !$ev;
    die "Expecting a DJabberd::XMLElement, got a $ev" unless UNIVERSAL::isa($ev, "DJabberd::XMLElement");
    return $ev->as_xml;
}

# if using $timeout, you're declaring that you can expect nothing and
# undef is returned.  otherwise must return XML.  (or die after 10 seconds)
sub recv_xml_obj {
    my ($self, $timeout) = @_;
    my $ev = $self->get_event($timeout, 1);
    die unless UNIVERSAL::isa($ev, "DJabberd::XMLElement");
    return $ev;
}

sub get_stream_start {
    my $self = shift;
    my $ev = $self->get_event();
    die unless $ev && $ev->isa("DJabberd::StreamStart");
    return $ev;
}

sub send_xml {
    my $self = shift;
    my $xml  = shift;
    $self->{sock}->print($xml);
}

sub create_fresh_account {
    my $self = shift;
    eval {
        warn "trying to login for " . $self->username . " ...\n" if $ENV{TESTDEBUG};
        if ($self->login) {
            warn "  Logged in.\n" if $ENV{TESTDEBUG};
            $self->send_xml(qq{<iq type='set' id='unreg1'>
                                   <query xmlns='jabber:iq:register'>
                                   <remove/>
                                   </query>
                                   </iq>});
            my $res = $self->recv_xml;
            die "Couldn't wipe our account: $res" unless $res =~ /type=.result./;
            warn "  unregistered.\n" if $ENV{TESTDEBUG};
        }
    };
    warn "Error logging in: [$@]" if $@ && $ENV{TESTDEBUG};

    warn "Connecting...\n" if $ENV{TESTDEBUG};
    $self->connect
        or die "Couldn't connect to server";

    warn "Connected, getting auth types..\n" if $ENV{TESTDEBUG};
    $self->send_xml(qq{<iq type='get' id='reg1'>
                             <query xmlns='jabber:iq:register'/>
                             </iq>});

    my $res = $self->recv_xml;
    die "No in-band reg instructions: $res" unless $res =~ qr/<instructions>/;

    my $user = $self->username;
    my $pass = $self->password;

    warn "registering ($user / $pass)...\n" if $ENV{TESTDEBUG};
    $self->send_xml(qq{<iq type='set' id='reg1'>
                             <query xmlns='jabber:iq:register'>
                             <username>$user</username>
                             <password>$pass</password>
                             </query>
                             </iq>});

    $res = $self->recv_xml;
    die "failed to reg account: $res" unless $res =~ qr/type=.result./;
    warn "created account.\n" if $ENV{TESTDEBUG};
    $self->disconnect;
    return 1;
}

sub disconnect {
    my $self = shift;
    $self->{sock} = undef;
}

sub connect {
    my $self = shift;

    my $sock;
    my $addr;
    if ($addr = $self->{unixdomainsocket}) {
        $sock = IO::Socket::UNIX->new(Peer => $addr);
    } else {
        $addr = join(':',
                     $self->server->peeraddr,
                     $self->server->clientport);
        for (1..3) {
            $sock = IO::Socket::INET->new(PeerAddr => $addr,
                                          Timeout => 1);
            last if $sock;
            sleep 1;
        }
    }

    $self->{sock} = $sock
        or die "Cannot connect to server " . $self->server->id . " ($addr)";


    $self->send_stream_start;
    $self->{ss} = $self->get_stream_start();

    my $features = $self->recv_xml;
    warn "FEATURES: $features" if $ENV{TESTDEBUG};
    die "no features" unless $features =~ /^<([^\:]+\:)?features\b/;
    return 1;
}

sub send_stream_start {
    my $self = shift;
    my $sock = $self->{sock};
    my $to = $self->server->hostname;
    print $sock "
   <stream:stream
       xmlns:stream='http://etherx.jabber.org/streams'
       xmlns='jabber:client' to='$to' version='1.0'>";
}

sub sasl_login {
    my $self = shift;
    my $sasl = shift;
    my $res  = shift || '';
    my $sec  = shift;

    warn "connecting for sasl login..\n" if $ENV{TESTDEBUG};
    $self->connect or die "Failed to connect";

    warn ".. connected after sasl login.\n" if $ENV{TESTDEBUG};

    my $ss = $self->{ss};
    my $sock = $self->{sock};
    my $to = $self->server->hostname;
    my $conn = $sasl->client_new("xmpp", $to, $sec);

    my $mechanism = $conn->mechanism;
    my $init = $conn->client_start();
    warn "sending conn auth...$init\n" if $ENV{TESTDEBUG};
    $init = $init ? encode_base64($init, '') : "=";
    print $sock "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='$mechanism'>$init</auth>";

    my $got_success_already = 0;
    while ($conn->need_step) {
        my $challenge = $self->recv_xml;
        warn "challenge response: [$challenge]\n" if $ENV{TESTDEBUG};
        die "Didn't get expected response: $challenge" unless $challenge =~ /challenge|success\b/;

        if ($challenge =~ s/^.*>(.+)<.*$/$1/sm) {
            $challenge = decode_base64($challenge);
            warn "decoded challenge: [$challenge]\n" if $ENV{TESTDEBUG};
        }

        my $response = $conn->client_step($challenge);
        if ($conn->is_success) {
            $got_success_already = 1;
        }
        else {
            warn "sending conn response [$response]\n" if $ENV{TESTDEBUG};
            $response = $response ? encode_base64($response, '') : "="; # dupe
            print $sock "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>$response</response>";
        }
    }
    if (my $error = $conn->error) {
        die "error in SASL $error";
    }

    unless ($got_success_already) {
        my $final = $self->recv_xml;
        die "auth error $final" unless $final && $final =~ /success/;
    }
    $self->{ss} = undef;
    delete $self->{ss};

    $self->send_stream_start;
    $self->get_stream_start;

    my $features = $self->recv_xml;
    warn "FEATURES: $features" if $ENV{TESTDEBUG};
    die "no features" unless $features =~ /^<([^\:]+\:)?features\b/;
    die "no bind"     unless $features =~ /bind\b/sm;
    die "no session"  unless $features =~ /session\b/sm;

    return $self->bind_resource($res);
}

sub bind_resource {
    my $self = shift;
    my $res  = shift;
    my $sock = $self->{sock};

    print $sock <<EOB;
<iq type='set' id='purple81e4b57b'><bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'><resource>$res</resource></bind></iq>
EOB
    my $iq = $self->recv_xml_obj;
    die "invalid bind response" unless $iq->element_name eq 'iq';
    my $bind = $iq->first_element;
    die "invalid bind response " unless $bind->element_name eq 'bind';
    my $jid_el = $bind  ->first_element or die "no jid elt...";
    my $jid    = $jid_el->first_child   or die "no jid...";
    return DJabberd::JID->new($jid);
}

sub abort_sasl_login {
    my $self = shift;
    my $sasl = shift;
    my $sec  = shift;

    $self->connect or die "Failed to connect";
    my $ss = $self->{ss};
    my $sock = $self->{sock};
    my $to = $self->server->hostname;
    my $conn = $sasl->client_new("xmpp", $to, $sec);

    my $mechanism = $conn->mechanism;
    my $init = $conn->client_start();
    $init = $init ? encode_base64($init, '') : "=";
    print $sock "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='$mechanism'>$init</auth>";

    my $challenge = $self->recv_xml;
    print $sock "<abort xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>";
    return $self->recv_xml;
}

sub login {
    my $self = shift;
    my $password = shift || $self->password;

    warn "connecting for login..\n" if $ENV{TESTDEBUG};
    $self->connect or die "Failed to connect";

    warn ".. connected after login.\n" if $ENV{TESTDEBUG};

    my $ss = $self->{ss};
    my $sock = $self->{sock};
    my $to = $self->server->hostname;

    my $username = $self->{name};

    warn "getting auth types...\n" if $ENV{TESTDEBUG};
    print $sock "<iq type='get' id='auth1'>
  <query xmlns='jabber:iq:auth'/>
</iq>";

    my $authreply = $self->recv_xml;
    warn "auth reply for types: [$authreply]\n" if $ENV{TESTDEBUG};

    die "didn't get reply" unless $authreply =~ /id=.auth1\b/;
    my $response = "";
    if ($authreply =~ /\bpassword\b/) {
        $response = "<password>$password</password>";
    } elsif ($authreply =~ /\bdigest\b/) {
        use Digest::SHA1 qw(sha1_hex);
        my $dig = lc(sha1_hex($ss->id . $password));
        $response = "<digest>$dig</digest>";
    } else {
        die "can't do password nor digest auth: [$authreply]";
    }

    my $res = $self->resource;
    print $sock "<iq type='set' id='auth2'>
  <query xmlns='jabber:iq:auth'>
    <username>$username</username>
    $response
    <resource>$res</resource>
  </query>
</iq>";

    my $authreply2 = $self->recv_xml;
    warn "auth reply post-login: [$authreply2]\n" if $ENV{TESTDEBUG};

    die "no reply" unless $authreply2 =~ /id=.auth2\b/;
    die "bad password" unless $authreply2 =~ /type=.result\b/;

    $self->{ss} = undef;
    delete $self->{ss};

    return 1;
}

sub get_roster {
    my $self = shift;
    $self->{requested_roster}++;
    $self->send_xml(qq{<iq type='get' id='rosterplz'><query xmlns='jabber:iq:roster'/></iq>});
    my $xmlo = $self->recv_xml_obj;
    die unless $xmlo->as_xml =~ /type=.result.+jabber:iq:roster/s;
    return $xmlo;
}

sub initial_presence {
    my $self = shift;
    my $message = shift || 'Default Message';
    $self->send_xml(qq{<presence><status>$message</status></presence>});
    $self->{initial_presence}++;
}

# assumes no roster has been requested yet.
# assumes no initial presence has been sent yet.
sub subscribe_successfully {
    my ($self, $other) = @_;

    $self->send_xml(qq{<presence to='$other' type='subscribe' />});

    $other->recv_xml =~ /<pre.+\btype=.subscribe\b/
        or die "other party ($other) didn't get type='subscribe'\n";

    $other->send_xml(qq{<presence to='$self' type='subscribed' />});

    main::test_responses($self,
                         "presence" => sub {
                             my ($xo, $xml) = @_;
                             return 0 if $xml =~ /\btype=/;
                             return 0 unless $xml =~ /<presence\b/;
                             return 1;
                         },
                         "presence2" => sub {
                             my ($xo, $xml) = @_;
                             return 0 if $xml =~ /\btype=/;
                             return 0 unless $xml =~ /<presence\b/;
                             return 1;
                         },
                         "presence subscribed" => sub {
                             my ($xo, $xml) = @_;
                             return 0 unless $xml =~ /\btype=.subscribed\b/;
                             return 0 unless $xml =~ /\bfrom=.$other\b/;
                             return 1;
                         },
                         );
}

# this code is a bit duplicated from above, but it deals
# with initial presence and roster requested
# it also doesn't ack it

sub subscribe_to {
    my ($self, $to) = @_;
    my $from = $self;

    $from->send_xml(qq{<presence to='$to' type='subscribe' />});

    $from->{state}->{subscribe_to}->{$to}++;
    my @test;

    if ($from->{requested_roster}) {
        push @test, "roster push" => sub {
            my ($xo, $xml) = @_;
            my $subscription = $from->{state}->{subscribed_from}->{$to} ? "from" : "none";
            return 0 unless $xml =~ /jid=.$to./;
            return 0 unless $xml =~ /\bsubscription=.$subscription\b/;
            return 0 if !$from->{state}->{subscribed_from}->{$to} && $xml !~ /ask=.subscribe\b/;
            return 1;
        },
    }


    main::test_responses($from, @test) if(@test);
    my $xml = $to->recv_xml_obj;

    main::is($xml->attr("{}to"), $to->as_string, "to pb");
    main::is($xml->attr("{}from"), $from->as_string, "from a");
    main::is($xml->attr("{}type"), "subscribe", "type subscribe");
    $to->{state}->{subscribe_from}->{$from}++;



}

sub accept_subscription_from {
    my ($self, $from) = @_;

    $self->send_xml(qq{<presence to='$from' type='subscribed' />});
    $self->{state}->{subscribed_from}->{$from}++;

    my @test;
    if ($from->{requested_roster}) {
        push @test,"roster push" => sub {
                       my ($xo, $xml) = @_;
                       warn "B) $xml";
                       if ($from->{state}->{subscribed_from}->{$self}) {
                           $xml =~ /\bsubscription=.from\b/ && $xml =~ /ask=.subscribe\b/;
                       } else {
                           $xml =~ /\bsubscription=.to\b/;
                       }
                   };
        push @test,"roster push" => sub {
                       my ($xo, $xml) = @_;
                       if ($from->{state}->{subscribed_from}->{$self} && $self->{state}->{subscribed_from}->{$from}) {
                           $xml =~ /\bsubscription=.both\b/;
                       } else {
                           $xml =~ /\bsubscription=.to\b/;
                           1;
                       }
                   };

    }



    if ($from->{initial_presence} && $self->{initial_presence}) {
        push @test, "presence of user" => sub {
            my ($xo, $xml) = @_;
            $xml =~ /Default Message/;
        };
        push @test, "presence of user2" => sub {
            my ($xo, $xml) = @_;
            $xml =~ /Default Message/;
        };
    }

    if ($from->{initial_presence}) {
        push @test, "presence subscribed" => sub {
            my ($xo, $xml) = @_;
            return 0 unless $xml =~ /\btype=.subscribed\b/;
            return 0 unless $xml =~ /\bfrom=.$self\b/;
            return 1;
        };
    }
     main::test_responses($from, @test) if (@test);
    $from->{state}->{subscribed_to}->{$self}++;
    my $xml = $self->recv_xml;
    main::like($xml, qr/to=.$self\b/, "to $self");
    if ($from->{state}->{subscribed_from}->{$self} && $self->{state}->{subscribed_from}->{$from}) {
        main::like($xml, qr/subscription=.both\b/, "both");
    } else {
        main::like($xml, qr/subscription=.from\b/, "from");
    }
}
1;