Return to ras-load CVS log

Up to [Coherent Logic Development] / RasLoadTester

Annotation of RasLoadTester/ras-load, revision 1.1

1.1     ! snw         1: #!/usr/bin/env perl
        !             2: 
        !             3: use Net::OSCAR;
        !             4: use Getopt::Long;
        !             5: 
        !             6: my $bot_version = "0.0.1";
        !             7: my $botsn = '';
        !             8: my $botct = 1;
        !             9: my $botno = 0;
        !            10: my $oscar = '';
        !            11: my $online = 0;
        !            12: my $room = '';
        !            13: 
        !            14: sub signon_done
        !            15: {
        !            16:     my ($oscar) = @_;
        !            17:     
        !            18:     print "$botsn:  signon done\n";
        !            19:     $online = 1;
        !            20:     $oscar->chat_join("General", 5);    
        !            21: }
        !            22: 
        !            23: sub chat_joined
        !            24: {
        !            25:     my($oscar, $chatname, $chat) = @_;
        !            26: 
        !            27:     $room = $chat;
        !            28:     
        !            29:     print "$botsn:  chat joined\n";
        !            30: }
        !            31: 
        !            32: sub chat_im_in
        !            33: {
        !            34: 
        !            35: }
        !            36: 
        !            37: sub im_in
        !            38: {
        !            39:     my($oscar, $sender, $message, $is_away) = @_;
        !            40:     print "$botsn:  message received from $sender\n";
        !            41: }
        !            42: 
        !            43: sub oscar_error
        !            44: {
        !            45:     my($oscar, $connection, $error, $description, $fatal) = @_;
        !            46: 
        !            47:     if($fatal != 0) {
        !            48:         print "$botsn:  fatal OSCAR error:  $description\n";        
        !            49:     }
        !            50:     else {
        !            51:         print "$botsn:  recoverable OSCAR error: $description\n";
        !            52:     }
        !            53: }
        !            54: 
        !            55: sub simulate_load
        !            56: {
        !            57:     my @services = ('im', 'chat', 'dice');    
        !            58:     my $tgtno = 0 + int(rand(($botct + 1) - 0));
        !            59:     my $tgtsn = "ldtest$tgtno";
        !            60: 
        !            61:     my $tgtsvc = $services[rand @services];
        !            62:     
        !            63:     if($tgtsvc eq "im") {
        !            64:         $oscar->send_im($tgtsn, "load test message");
        !            65:     }
        !            66:     elsif($tgtsvc eq "chat") {
        !            67:         if(ref($room) eq "Net::OSCAR::Connection::Chat") {
        !            68:             $room->chat_send("load test message");            
        !            69:         }
        !            70:     }
        !            71:     elsif($tgtsvc eq 'dice') {
        !            72:         if(ref($room) eq "Net::OSCAR::Connection::Chat") {
        !            73:             $room->chat_send("//roll-dice15-sides999");
        !            74:         }
        !            75:     }
        !            76:     sleep 1;
        !            77:     
        !            78: }
        !            79: 
        !            80: sub main
        !            81: {
        !            82:     my $botpw = '';
        !            83:     my $botsrv = '';
        !            84:     
        !            85:     GetOptions("botno=n" => \$botno,
        !            86:                "botct=n" => \$botct,
        !            87:                "aimpw=s" => \$botpw,
        !            88:                "aimhost=s" => \$botsrv)
        !            89:         or die("error in command line arguments");
        !            90: 
        !            91:     $botsn = "ldtest$botno";
        !            92:     
        !            93:     my %signon = (
        !            94:         screenname => $botsn,
        !            95:         password => $botpw,
        !            96:         host => $botsrv,
        !            97:         ); 
        !            98: 
        !            99:     $oscar = Net::OSCAR->new();
        !           100:     my $realno = $botno + 1;
        !           101:     
        !           102:     print "$botsn: $realno of $botct on host $botsrv\n";   
        !           103:     
        !           104:     $oscar->set_callback_signon_done(\&signon_done);
        !           105:     $oscar->set_callback_chat_joined(\&chat_joined);
        !           106:     $oscar->set_callback_chat_im_in(\&chat_im_in);
        !           107:     $oscar->set_callback_im_in(\&im_in);
        !           108:     $oscar->set_callback_error(\&oscar_error);
        !           109:     $oscar->signon(%signon);
        !           110: 
        !           111:     while(1) {
        !           112:         $oscar->do_one_loop();
        !           113:         if($online == 1) {
        !           114:             simulate_load();
        !           115:         }
        !           116:     }
        !           117: }
        !           118: 
        !           119: main()
        !           120: