view release on metacpan or  search on metacpan

t/Crypt-OTR.t  view on Meta::CPAN

    $_->join foreach ($alice_thread, $bob_thread);

    return 1;
}

sub test_init {
    my ($user, $dest) = @_;

    lock( $test_init );

    my $otr = new Crypt::OTR(
        account_name     => $user,
        protocol         => "crypt-otr-test",
        max_message_size => 2000, 
    );

    # callback to inject an encrypted message (add to recipient's buffer)
    my $inject = sub {
        my ( $ptr, $account_name, $protocol, $dest_account, $message) = @_;
        die "no message passed to inject" unless $message;
        lock( @$dest );
        push @$dest, $message;
    };

    # got a message from the OTR system (e.g. "Heartbeat received from alice")
    my $send_system_message = sub {
        my( $ptr, $account_name, $protocol, $dest_account, $message) = @_;
        
        if( $dest_account eq $u2 ){
            lock( @$bob_buf );
            push @$bob_buf, $message;
        }

        if( $dest_account eq $u1 ){
            lock( @$alice_buf );
            push @$alice_buf, $message;
        }
    };

    # created an unverified connection
    my $unverified_cb = sub {
        my($ptr, $username) = @_;

        pass("Unverified connection started with $username");
        lock( %connected );
        $connected{ $username } = 1;
        $established->{$username} = 1;
    };

    # created a verified connection, not tested yet
    # TODO: add tests for fingerprint verification
    my $verified_cb = sub {
        my($ptr, $username) = @_;
        
        pass("Secure connection established with $username");
        lock(%secured);
        $secured{ $username } = 1;
    };
    

    #### self-explanatory OTR callbacks below
    my $disconnected_cb = sub {
        my( $ptr, $username ) = @_;

        #print "Disconnected\n";

        lock( %disconnected );
        $disconnected{ $username } = 1;
    };
    my $error_cb = sub {
        my($ptr, $accountname, $protocol, $username, $title, $primary, $secondary) = @_;
        
        print "Error! -- $accountname -- $protocol -- $username -- $title -- $primary -- $secondary\n";
    };
    my $warning_cb = sub {
        my($ptr, $accountname, $protocol, $username, $title, $primary, $secondary) = @_;
        
        print "Warning! -- $accountname -- $protocol -- $username -- $title -- $primary -- $secondary\n";
    };
    my $info_cb = sub {
        my($ptr, $accountname, $protocol, $username, $title, $primary, $secondary) = @_;
        
        #print "Info -- $accountname -- $protocol -- $username -- $title -- $primary -- $secondary\n";

        if( $accountname eq $u2 ){
            lock( @$bob_info_buf );
            push @$bob_info_buf, $primary;
        }
    };
    
    my $new_fingerprint_cb = sub {
        my( $ptr, $accountname, $protocol, $username, $fingerprint) = @_;

		lock( %new_fingerprint );
		$new_fingerprint{ $username } = 1;
        
        pass("New fingerprint for $username = $fingerprint");
    };

    my $still_connected_cb = sub {
        my( $ptr, $username ) = @_;
        
        #print "Still connected with $username\n";
    };

    # socialist millionares protocol, where one party creates a shared
    # secret and the other party must generate the same secret
	my $smp_request_cb = sub {
		my( $ptr, $protocol, $username, $question ) = @_;
		
		if( $question ){
                    # this is never reached?
                    print "Question asked: $question\n";
		}
		
		pass("$username requesting SMP shared secret");

		lock( %smp_request );
		$smp_request{ $username } = 1;
	};

    # install callbacks
    $otr->set_callback('inject' => $inject);
    $otr->set_callback('otr_message' => $send_system_message);

    $otr->set_callback('verified' => $verified_cb);
    $otr->set_callback('unverified' => $unverified_cb);
    $otr->set_callback('disconnect' => $disconnected_cb);
    $otr->set_callback('still_connected' => $still_connected_cb);

    $otr->set_callback('error' => $error_cb);
    $otr->set_callback('warning' => $warning_cb);
    $otr->set_callback('info' => $info_cb);
    $otr->set_callback('smp_request' => $smp_request_cb);

    $otr->set_callback('new_fingerprint' => $new_fingerprint_cb);

    $otr->load_privkey;

    return $otr;
}