Return to ras-load CVS log

Up to [Coherent Logic Development] / RasLoadTester

Annotation of RasLoadTester/ras-load, revision 1.2

1.1       snw         1: #!/usr/bin/env perl
                      2: 
1.2     ! snw         3: # 
        !             4: # ChivaNet Load Tester
        !             5: #  Copyright (C) 2025 Coherent Logic Development LLC
        !             6: #
        !             7: # Author: Serena Willis <snw@coherent-logic.com>
        !             8: #
        !             9: # Licensed AGPL-3.0
        !            10: #
        !            11: #   $Log$
        !            12: #
        !            13: #
        !            14: 
        !            15: 
1.1       snw        16: use Net::OSCAR;
                     17: use Getopt::Long;
                     18: 
                     19: my $bot_version = "0.0.1";
                     20: my $botsn = '';
                     21: my $botct = 1;
                     22: my $botno = 0;
                     23: my $oscar = '';
                     24: my $online = 0;
                     25: my $room = '';
1.2     ! snw        26: my %signon = ();
        !            27: my $ticks = 0;
        !            28: my $heartbeat = time();
        !            29: my $hbchk_pending = 0;
1.1       snw        30: 
                     31: sub signon_done
                     32: {
                     33:     my ($oscar) = @_;
                     34:     
                     35:     print "$botsn:  signon done\n";
                     36:     $online = 1;
                     37:     $oscar->chat_join("General", 5);    
                     38: }
                     39: 
                     40: sub chat_joined
                     41: {
                     42:     my($oscar, $chatname, $chat) = @_;
                     43: 
                     44:     $room = $chat;
                     45:     
                     46:     print "$botsn:  chat joined\n";
                     47: }
                     48: 
                     49: sub chat_im_in
                     50: {
                     51: 
                     52: }
                     53: 
                     54: sub im_in
                     55: {
                     56:     my($oscar, $sender, $message, $is_away) = @_;
1.2     ! snw        57:     
        !            58:     if($message eq "ltping") {
        !            59:         $oscar->send_im($sender, "ltpong");     
        !            60:     }
        !            61:     elsif($message eq "ltpong") {
        !            62:         print "$botsn:  heartbeat OK\n";
        !            63:         $heartbeat = time();
        !            64:         $hbchk_pending = 0;
        !            65:     }
1.1       snw        66: }
                     67: 
                     68: sub oscar_error
                     69: {
                     70:     my($oscar, $connection, $error, $description, $fatal) = @_;
                     71: 
                     72:     if($fatal != 0) {
1.2     ! snw        73:         die "$botsn:  fatal OSCAR error:  $description\n";       
1.1       snw        74:     }
                     75:     else {
                     76:         print "$botsn:  recoverable OSCAR error: $description\n";
                     77:     }
                     78: }
                     79: 
                     80: sub simulate_load
                     81: {
                     82:     my @services = ('im', 'chat', 'dice');    
                     83:     my $tgtno = 0 + int(rand(($botct + 1) - 0));
                     84:     my $tgtsn = "ldtest$tgtno";
                     85: 
                     86:     my $tgtsvc = $services[rand @services];
                     87:     
                     88:     if($tgtsvc eq "im") {
                     89:         $oscar->send_im($tgtsn, "load test message");
                     90:     }
                     91:     elsif($tgtsvc eq "chat") {
                     92:         if(ref($room) eq "Net::OSCAR::Connection::Chat") {
                     93:             $room->chat_send("load test message");            
                     94:         }
                     95:     }
                     96:     elsif($tgtsvc eq 'dice') {
                     97:         if(ref($room) eq "Net::OSCAR::Connection::Chat") {
                     98:             $room->chat_send("//roll-dice15-sides999");
                     99:         }
                    100:     }
1.2     ! snw       101:     $ticks = $ticks + 1;
        !           102: 
        !           103:     if($ticks > 20) {
        !           104:         $heartbeat = time();
        !           105:         $oscar->send_im($botsn, "ltping");
        !           106:         print "$botsn:  heartbeat check\n";
        !           107:         $hbchk_pending = 1;
        !           108:         $ticks = 0;
        !           109:     }
        !           110: 
        !           111:     if($hbchk_pending == 1) {
        !           112:         if(time() - $heartbeat > 5) {
        !           113:             die "$botsn:  heartbeat check FAILED; bot terminating\n";
        !           114:         }
        !           115:     }
1.1       snw       116:     
1.2     ! snw       117:     sleep 1
1.1       snw       118: }
                    119: 
                    120: sub main
                    121: {
                    122:     my $botpw = '';
                    123:     my $botsrv = '';
                    124:     
                    125:     GetOptions("botno=n" => \$botno,
                    126:                "botct=n" => \$botct,
                    127:                "aimpw=s" => \$botpw,
                    128:                "aimhost=s" => \$botsrv)
                    129:         or die("error in command line arguments");
                    130: 
1.2     ! snw       131:     $botsn = "lt$botno\pr$$";
1.1       snw       132:     
1.2     ! snw       133:     %signon = (
1.1       snw       134:         screenname => $botsn,
                    135:         password => $botpw,
                    136:         host => $botsrv,
                    137:         ); 
                    138: 
                    139:     $oscar = Net::OSCAR->new();
                    140:     my $realno = $botno + 1;
                    141:     
                    142:     print "$botsn: $realno of $botct on host $botsrv\n";   
                    143:     
                    144:     $oscar->set_callback_signon_done(\&signon_done);
                    145:     $oscar->set_callback_chat_joined(\&chat_joined);
                    146:     $oscar->set_callback_chat_im_in(\&chat_im_in);
                    147:     $oscar->set_callback_im_in(\&im_in);
                    148:     $oscar->set_callback_error(\&oscar_error);
                    149:     $oscar->signon(%signon);
                    150: 
                    151:     while(1) {
                    152:         $oscar->do_one_loop();
                    153:         if($online == 1) {
                    154:             simulate_load();
1.2     ! snw       155:         }        
1.1       snw       156:     }
                    157: }
                    158: 
                    159: main()
                    160: