Return to ras-load CVS log

Up to [Coherent Logic Development] / RasLoadTester

Annotation of RasLoadTester/ras-load, revision 1.3

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