How can I get these Perl scripts to delay? - perl

I'm making a simple IRC bot in Perl that can be used to "hunt ducks" in response to this IRC game bot. I'm doing this on a private scripting channel, irc.freenode.net ##duckhunt2 so as not to interfere with real people playing the game.
So far I've tried making a Perl bot using Net::IRC and a plugin for XChat, with my code here. The duck source bot sends a message like
・゜゜・。。・゜゜\_O< quack!
a random amount of time in between 8-60 minutes since the last duck was shot to let you know that a duck has arrived. You can then reply with .bang to shoot the duck and get one point added to your score. However, if you reply too quickly (within one second), it puts you in a 2 hour cooldown mode where you can't shoot any ducks. Sometimes it also throws in 7 second cooldowns because of "jammed guns" and such, as shown in line 272 of the game bot code.
Perl code
use Net::IRC;
use Time::HiRes qw(usleep nanosleep);
$ducksource = 'DUCK_SOURCE';
$server = 'IRC_SERVER';
$channel = 'IRC_CHANNEL';
$botnick = 'BOT_NICKNAME';
$botnick2 = 'BOT_BACKUP_NICKNAME';
$password = 'BOT_PASSWORD';
$botadmin = 'BOT_ADMIN_NICKNAME';
$irc = new Net::IRC;
$conn = $irc->newconn(
Nick => $botnick,
Server => $server,
Port => IRC_SERVER_PORT,
Username => $botnick
);
$conn->add_global_handler('376', \&on_connect);
$conn->add_global_handler('disconnect', \&on_disconnect);
$conn->add_global_handler('kick', \&on_kick);
$conn->add_global_handler('msg', \&on_msg);
$conn->add_global_handler('public', \&on_public);
$irc->start;
sub on_connect {
$self = shift;
$self->privmsg('nickserv', "identify $password");
$self->join($channel);
print "Connected\n";
}
sub on_disconnect {
$self = shift;
print "Disconnected, attempting to reconnect\n";
$self->connect();
}
sub on_kick {
$self = shift;
$self->join($channel);
$self->privmsg('nickserv', "/nick $botnick");
}
sub on_msg {
$self = shift;
$event = shift;
if ($event->nick eq $botadmin) {
foreach $arg ($event->args) {
if ($arg =~ m/uptime/) {
$self->privmsg($botadmin, `uptime`);
}
}
}
}
sub on_public {
$self = shift;
$event = shift;
if ($event->nick eq $ducksource) {
foreach $arg ($event->args) {
if (($arg =~ m/</) && ($arg !~ m/>/)) {
usleep(250000);
$self->privmsg($channel, ".bang");
}
if ( ($arg =~ m/missed/)
|| ($arg =~ m/jammed/)
|| ($arg =~ m/luck/)
|| ($arg =~ m/WTF/)) {
$self->privmsg('nickserv', "/nick $botnick2");
$self->privmsg($channel, ".bang");
$self->privmsg('nickserv', "/nick $botnick");
}
if (($arg =~ m/script/) || ($arg =~ m/period/)) {
$self->privmsg('nickserv', "/nick $botnick2");
$self->privmsg($channel, ".bang");
}
}
}
}
The Perl bot connects to the server, joins the chat room, and responds to a duck appearing, but I can't get it to delay the sending of the command .bang so that the game bot receives it after 1 second has passed and I don't go into the two-hour cooldown mode.
I know that the Perl sleep command only accept multiples of one second. I need to delay 0.25 seconds because it takes about 0.75 seconds for the message to reach the game bot, so I've tried using Time::HiRes and the usleep command, which uses microseconds (1,000 microseconds = 1 millisecond).
On line 61 of my code, I added usleep(250000) which should make the script pause for 0.25s before sending the message on the next line
$self->privmsg($channel, ".bang")
But the script does not wait -- it just sends the message as normal. It acts like it is ignoring the usleep command.
How can I fix this and make the bot wait before it sends the message?
Secondly, I'm confused over how to change nicknames. If the game bot gives me a 7 second cooldown, I'd like to quickly change my nick to another nick (e.g. HunterBot6000 to HunterBot6000_) shoot the duck (.bang), and change my nick back before another bot gets the duck. Typically you accomplish a nick change through the /nick NEWNICK command. However, I've tried sending this command to the channel and NickServ, and this doesn't change my nickname. How should I accomplish this?
I also tried writing an XChat plugin for the script to see if that would get rid of the timing issue, but that doesn't work either. After connecting to the server and joining the chat room in XChat, I load the plugin, and I have the same issue -- it responds to ducks with .bang but I cannot get it to wait before sending.
You can see the documentation Writing a simple XChat Perl Script. What am I doing wrong?

You're asking multiple questions, but I can only answer one from my phone
You can change nicknames by sending
NICK newnick
Further information can be found in the RFC 2812.
However, Net::IRC might have more appropriate means for that.

I have also had trouble from usleep from Time::HiRes. This should effect a sleep of 250ms:
select(undef, undef, undef, 0.25);

Thank you for everyone's help. I was able to get the usleep command working and verify that it was delaying properly by changing the delay to a larger amount of seconds (e.g. usleep(25000000), 25 seconds) and then changing back to 0.25 seconds by removing one 0 at a time. I also added print Time::HiRes::time; before and after to verify that the delay was working. I also found that the proper command to change nicks is $self->nick($botnick2);, even though it is nowhere to be found in any Net::IRC documentation. Once again, thank you all for the help and advice.

Related

Mojo IOLoop blocks app when ran

I use Mojo::IOLoop to perform background tasks that should be run every so often, and am doing this using Mojo::IOLoop::recurring. I do this within the Mojo app itself:
sub startup {
my $self = shift;
$self->setup_routes();
... more setup
my $sleep_time = $self->config()->{sleep_time};
Mojo::IOLoop->recurring($sleep_time => sub {
my $sync = My::BackgroundTask->new(
sleep_time => $sleep_time,
);
$sync->run();
});
local $SIG{TERM} = sub {
Mojo::IOLoop->stop_gracefully;
};
}
When the time comes for the above loop to run, when trying to view the actual app the site times out, and when it's finished the app is available again. Not sure why this is happening, would someone be able to explain?
EDIT:
My::BackgroundTask::run
sub run {
my ($self, $data) = #_;
while ( scalar(#{$data}) > 0 ) {
my #batch = splice(#{$data}, 0, 100);
$self->schema->update_batch_of_data( \#batch );
# sleep for a while to not be rude :P
sleep ($self->sleep_time);
}
return 1;
}
Are you saying that it sleeps for $sleep_time seconds? Because that's not how it's supposed to work. It should exit and continue the process next time the recurring starts it up. As it is, you're trying to start another copy of the task of the task each time recurring kicks in, and maybe your task is hanging because it's unable to start more than one task? Just a guess, Does it ever return from $sync->run()? And what sort of thing is $sync?
– Borodin
yeah seems to have been because of the sleep inbetween, thanks! Any suggestions on how to be friendly when calling external sources and not milking them in one go? :P – a7omiton
Yes, you need a similar recurring timer, but only do a fraction of the work at each step
– Borodin

Capturing screen failed when the active window has an error message box

I'm writing a software testing framework using perl on Windows platform, which run test cases by calling the software under test. If a test case fails, the framework will capture the screen so we could get more information about the failure.
At first I used an small program called boxcutter-fs.exe. So all I need is to call this program when test case fails:
system("boxcutter-fs.exe screenshot.png");
print "Failed: $?" if ($?);
When the framework handles a normal failure, it works great and give me the right failure screenshot. But I noticed that when the software crashed (an error message box would occur on the active window, and the software under test will be killed after a timeout), boxcutter-fs.exe exited with code 1, and didn't get any screenshot.
Then I turned to other solutions. The first alternative that I tried is Win32::GuiTest:
eval {
SendKeys('{PRTSCR}');
my $screen = Win32::Clipboard::GetBitmap() or die "No image captured: $!\n";
open BITMAP, "> screenshot.bmp" or die "Couldn't open bitmap file: $!\n";
binmode BITMAP;
print BITMAP $screen;
close BITMAP;
};
print "$#" if ($#);
The same result. This works well unless the software crash case occurred. The program reported No image captured so I think Win32::Clipboard::GetBitmap didn't get any thing in the Clipboard.
The last solution is Imager::Screenshot:
eval {
my $img = screenshot(hwnd => 'active');
$img->write(file => 'screenshot.bmp', type => 'bmp' )
or die "Failed: ", $img->{ERRSTR} , "\n";
};
print "$#" if ($#);
This time it gave a black screen screenshot (an all-black image) when the software crash case occurs. Still doesn't work.
Then I found that when the crash and error message box occurs, but the software hasn't been killed so the test framework is still hanging, using a small script with any of the solutions above could capture the screenshot. It seems they just fail at the moment when the software under test is being killed.
Since these 3 methods all use Win32 API to get the screenshot, I wonder they might fail due to the same issue? Any hints?
I studied the source code of Imager::Screenshot, and found the possible cause for the screenshot failure.
First of all, if I use -d option of perl to debug the screenshot script, when the software under test crashed and was killed after a timeout, the screenshot worked. So I suppose the screenshot failure should be a corner case in a specific situation.
Then I read the source code of Imager::Screenshot. Basically, it's a perl module calling XS extensions written with Win32 APIs. The processing flow is basically as following:
Use GetDC according to the window handler hwnd to get display device context dc
Use CreateCompatibleDC to get the device context handler hdc
Use GetDIBits to retrieve the bits of the device context, and write them to the bmp file
My problem is that when the software under test crashed and was killed, the hwnd of its window would be invalid at once, but it was still passed to GetDC to get the display device context, thus the result was invalid too (the bmp file was memset to all 0 at the beginning, so it's a black screenshot)
Now that I noticed the root cause was the invalid hwnd, I come up with a work around: take the screenshot before killing the software under test. I used Proc::Background and Win32::GuiTest. The key point is to ensure the software GUI is set as foreground window:
sub captureWindow {
my ($pid, $screenshot_name) = #_;
for my $hwnd (&findHwnd($pid)) {
if (Win32::GuiTest::SetActiveWindow($hwnd) && Win32::GuiTest::SetForegroundWindow($hwnd)) {
system("boxcutter-fs.exe $screenshot_name");
# send ALT+TAB key so the script was set back to foreground window
Win32::GuiTest::SendKeys("%{TAB}");
last;
}
}
}
sub findHwnd {
my ($target_pid) = #_;
my #target_hwnd;
EnumWindows(
Win32::API::Callback->new(sub {
my ($hwnd, $target_pid) = #_;
my $pid = 0xffffffff;
my $tid = GetWindowThreadProcessId($hwnd, $pid);
$pid = unpack 'L', $pid;
if ($target_pid == $pid) {
push #target_hwnd, $hwnd;
}
return 1;
}, 'NN', 'I'),
$target_pid,
);
return #target_hwnd;
}
sub monitorTestProcess {
my ($cmd, $timeout) = #_;
my $rs;
my $proc = Proc::Background->new($cmd);
my $pid = $proc->pid;
select(undef, undef, undef, 0.5);
&captureWindow($pid, "screenshot_begin.png");
my $timeCount = 0;
while ($proc->alive) {
if ($timeCount >= $timeout) {
&captureWindow($pid, "screenshot_timeout.png");
$proc->die;
last;
}
select(undef, undef, undef, 1);
$timeCount++;
}
return $rs;
}

How do I direct a Perl script to check for website response?

I’m pinging a website and checking the availability and sending an email only when it’s down. (That part is working just fine according to the code below.)
require LWP::UserAgent;
my $ua = LWP::UserAgent->new;
$ua->timeout(20);
my $response = $ua->get('https://www.Mysite.net/websuite/');
if (! $response->is_success) {
#print 'CMM Is up and Running';
$path = "C:\\prac\\send_email_failure.ps1";
$pwspath = "c:\\windows\\system32\\windowspowershell\\v1.0\\powershell.exe";
system("$pwspath -command $path"); #using powershell to invoke email utility
}
Now, I’m working on trying to expand the script to see whether
It can check once it’s down and send email (which it’s doing now) and don’t send email until it’s bought up. By the way, I’m using Windows task scheduler to run the script every twenty minutes.
After it sees the website is up it should goto its normal process of checking whether the site is down again and send email (for example the website went down then bought back up and again went down). I’m running the script every 20 mins using task scheduler.
Any help appreciated.
If your script is executed from some kind of scheduler you'll need to persist the status of your last request somehow. You could for example create a file which flags the last status as "down".
Or you could simply run your script as a daemon and schedule a check every 20 minutes (for example with AnyEvent). This way you wouldn't have to cope with filesystem related issues.
use LWP::UserAgent;
use AnyEvent;
my $previous = 1;
my $watch = AnyEvent->timer(interval => 1200, cb => sub {
if(check_status() == 0) {
if($previous == 1) {
# send e-mail
}
$previous = 0;
}
else {
$previous = 1;
}
});
AnyEvent->condvar->recv;
sub check_status {
my $ua = LWP::UserAgent->new(timeout => 20);
my $response = $ua->get('...');
return $response->is_success ? 1 : 0;
}

Pop Up in perl that goes away automatically after pause

I'm writing a script to assist people who'll scan a barcode and get a response to keep or dispose the scanned sample. I want to have a message, similar to tk's messagebox or Win32::MsgBox but one that requires no user interaction to go away after three seconds.
My thought was to create the messages in a child process, using alarm to kill the process after a delay. In Tk:
sub tmpMsgBox {
my ($message,$delay) = #_;
if (fork() == 0) {
my $topWin = MainWindow->new;
my $label = $topWin->Label();
my $ok = $topWin->Button();
$label->pack(-side => 'top');
$ok->pack(-side => 'bottom');
$label->configure(-text => $message);
$ok->configure(-text => 'Ok', -command => sub {exit});
$SIG{ALRM} = sub {exit};
alarm $delay || 1;
$topWin->MainLoop;
}
}
for (3..10) {
tmpMsgBox("This window will disappear in $_ seconds", $_);
}
I don't think Tk plays nicely with fork, though, so this idea probably won't work so well if you are also using Tk in your main process.
Desktop::Notify is the standard-compliant interface to the desktop's passive notification pop-ups.
perl -MDesktop::Notify -e'
Desktop::Notify
->new
->create(
body => q{why hello there},
timeout => 3000
)->show'
What you want to do is to send a destroy message to the window after your timeout (remembering to cancel the sending of the message if the user does choose something!) Tk's certainly capable of doing this.
# Make the timeout something like this...
$id = $widget->after(3000, sub {
$widget->destroy;
});
# To cancel, just do...
$id->cancel;
You also need to make sure that you don't block when the widget is forced to go away, of course. This also prevents trouble if someone kills the widget by other means too, so it's a double-bonus.

Why do I have to send multiple messages to my Jabber bot before it will logout?

I am trying to make my own Jabber bot but i have run into a little trouble. I have gotten my bot to respond to messages, however, if I try to change the bot's presence then it seems as though all of the messages you send to the bot get delayed.
What I mean is when I run the script I change the presence so I can see that it is online. Then when I send it a message it takes three before the callback subroutine I have set up for messages gets called. After the thirrd message is sent and the chat subroutine is called it still process the first message I sent.
This really doesn't pose too much of a problem except that I have it set up to log out when I send the message "logout" and it has to be followed by two more messages in order to log out. I am not sure what it is that I have to do to fix this but i think it has something to do with iq packets because I have an iq callback set as well and it gets called two times after setting the presence.
Here is my source code:
#!/usr/bin/perl
use strict;
use warnings;
#Libraries
use Net::Jabber;
use DBI;
use DBD::mysql;
#--------------- Config Vars -----------------
# Jabber Client
my $jbrHostname = "DOMAINNAME";
my $jbrUserName = "USERNAME";
my $jbrPassword = "PASSWORD";
my $jbrResource = "RESOURCE";
my $jbrBoss = new Net::Jabber::JID();
$jbrBoss->SetJID(userid=>"USERNAME",server=>$jbrHostname);
# MySQL
my $dbHostname = "DOMAINNAME";
my $dbName = "DATABASENAME";
my $dbUserName = "USERNAME";
my $dbPassword = "PASSWORD";
#--------------- End Config -----------------
# connect to the db
my $dbh = DBI->connect("DBI:mysql:database=$dbName;host=$dbHostname",$dbUserName, $dbPassword, {RaiseError => 1}) or die "Couldn't connect to the database: $!\n";
# create a new jabber client and connect to server
my $jabberBot = Net::Jabber::Client->new();
my $status = $jabberBot->Connect(hostname=>$jbrHostname) or die "Cannot connect ($!)\n";
my #results = $jabberBot->AuthSend(username=>$jbrUserName,password=>$jbrPassword,resource=>$jbrResource);
if($results[0] ne "ok")
{
die "Jabber auth error #results\n";
}
# set jabber bot callbacks
$jabberBot->SetMessageCallBacks(chat=>\&chat);
$jabberBot->SetPresenceCallBacks(available=>\&welcome);
$jabberBot->SetCallBacks(iq=>\&gotIQ);
$jabberBot->PresenceSend(type=>"available");
$jabberBot->Process(1);
sub welcome
{
$jabberBot->MessageSend(to=>$jbrBoss->GetJID(),subject=>"",body=>"Hello There!",type=>"chat",priority=>10);
&keepItGoing;
}
$jabberBot->MessageSend(to=>$jbrBoss->GetJID(),subject=>"",body=>"Hello There! Global...",type=>"chat",priority=>10);
#$jabberBot->Process(5);
&keepItGoing;
sub chat
{
print "Chat Called!\n";
my ($sessionID,$msg) = #_;
$jabberBot->MessageSend(to=>$msg->GetFrom(),subject=>"",body=>"Chatting!",type=>"chat",priority=>10);
if($msg->GetBody() ne 'logout')
{
print $msg->GetBody()."\n";
&keepItGoing;
}
else
{
&killBot($msg);
}
}
sub gotIQ
{
print $_[1]->GetID()."\n";
&chat;
}
sub keepItGoing
{
print "Movin' the chains!\n";
my $proc = $jabberBot->Process(1);
while(defined($proc) && $proc != 1)
{
$proc = $jabberBot->Process(1);
}
}
sub killBot
{
$jabberBot->MessageSend(to=>$_[0]->GetFrom(),subject=>"",body=>"Logging Out!",type=>"chat",priority=>10);
$jabberBot->Process(1);
$jabberBot->Disconnect();
exit;
}
Thanks for your help!
You've got resource starvation because of your keepItGoing routine. In general, trying to use XMPP synchronously like this is not going to work. I suggest getting your callbacks set up, then just calling Process() in one loop.
The docs for Process() say:
Process(integer) - takes the timeout period as an argument. If no
timeout is listed then the function blocks until
a packet is received. Otherwise it waits that
number of seconds and then exits so your program
can continue doing useful things. NOTE: This is
important for GUIs. You need to leave time to
process GUI commands even if you are waiting for
packets. The following are the possible return
values, and what they mean:
1 - Status ok, data received.
0 - Status ok, no data received.
undef - Status not ok, stop processing.
IMPORTANT: You need to check the output of every
Process. If you get an undef then the connection
died and you should behave accordingly.
Each time you call Process(), 0 or more of your callbacks will fire. You never know which, since it depends on server timing. If you want for Process() to return before sending something, you're almost always thinking synchronously, rather than asych, which kills you in XMPP.
In your case, if you remove the call to keepItGoing from chat(), I bet things will work more like you expect.
Replace the line:
$jabberBot->Process(1);
with these:
while (defined($jabberBot->Process(1))) {
# Do stuff here
}