Win32::Daemon script can't port to other machine
hi,
i write a Win32::Daemon script, and test successfully in my windows
2003 machine,
but when I copy to another windows 2003, it can't be started, and write
below error message in event-viewer:
Timeout (3 millisecond) waiting for service to connect.
Please help
below is the code:
use strict;
use warnings;
use Win32;
use Win32::Daemon;
main();
use constant SERVICE_NAME = 'MYSRV';
use constant SERVICE_DESC = 'My service';
sub main
{
# Get command line argument - if none passed, use empty string
my $opt = shift (@ARGV) || ;
# Check command line argument
if ($opt =~ /^(-i|--install)$/i)
{
install_service(SERVICE_NAME, SERVICE_DESC);
}
elsif ($opt =~ /^(-r|--remove)$/i)
{
remove_service(SERVICE_NAME);
}
elsif ($opt =~ /^(--run)$/i)
{
# Redirect STDOUT and STDERR to a log file
# Derive the name of the file from the name of the program
# The log file will be in the scripts directory, with extension .log
my ($cwd,$bn,$ext) =
( Win32::GetFullPathName($0) =~ /^(.*\\)(.*)\.(.*)$/ ) [0..2] ;
my $log = $cwd . $bn . .log;
# Redirect STDOUT and STDERR to log file
open(STDOUT, $log) or die Couldn't open $log for appending:
$!\n;
open(STDERR, STDOUT);
# Autoflush, no buffering
$|=1;
# Register the events which the service responds to
Win32::Daemon::RegisterCallbacks( {
start = \Callback_Start,
timer = \Callback_Running,
stop= \Callback_Stop,
pause = \Callback_Pause,
continue= \Callback_Continue,
} );
my %Context = (
last_state = SERVICE_STOPPED,
start_time = time(),
);
# Start the service passing in a context and indicating to callback
# using the Running event every 2000 milliseconds (2 seconds).
# NOTE: the StartService method with in 'callback mode' will block, in
other
# words it won't return until the service has stopped, but the
callbacks below
# will respond to the various events - START, STOP, PAUSE etc...
Win32::Daemon::StartService( \%Context, 2000 );
# Here the service has stopped
close STDERR; close STDOUT;
}
else
{
print No valid options passed - nothing done\n;
}
}
sub Callback_Running
{
my( $Event, $Context ) = @_;
# Note that here you want to check that the state
# is indeed SERVICE_RUNNING. Even though the Running
# callback is called it could have done so before
# calling the Start callback.
if( SERVICE_RUNNING == Win32::Daemon::State() )
{
# ... process your main stuff here...
# ... note that here there is no need to
# change the state
# For now just print hello to the STDOUT, which goes to the log file
print Hello!\n;
}
$Context-{last_state} = SERVICE_RUNNING;
}
sub Callback_Start
{
my( $Event, $Context ) = @_;
# Initialization code
# ...do whatever you need to do to start...
print Starting...\n;
$Context-{last_state} = SERVICE_RUNNING;
Win32::Daemon::State( SERVICE_RUNNING );
}
sub Callback_Pause
{
my( $Event, $Context ) = @_;
print Pausing...\n;
$Context-{last_state} = SERVICE_PAUSED;
Win32::Daemon::State( SERVICE_PAUSED );
}
sub Callback_Continue
{
my( $Event, $Context ) = @_;
print Continuing...\n;
$Context-{last_state} = SERVICE_RUNNING;
Win32::Daemon::State( SERVICE_RUNNING );
}
sub Callback_Stop
{
my( $Event, $Context ) = @_;
print Stopping...\n;
$Context-{last_state} = SERVICE_STOPPED;
Win32::Daemon::State( SERVICE_STOPPED );
# We need to notify the Daemon that we want to stop callbacks and the
service.
Win32::Daemon::StopService();
}
sub install_service
{
my ($srv_name, $srv_desc) = @_;
my ($path, $parameters);
# Get the program's full filename, break it down into constituent parts
my $fn = Win32::GetFullPathName($0);
my ($cwd,$bn,$ext) = ( $fn =~ /^(.*\\)(.*)\.(.*)$/ ) [0..2] ;
# Determine service's path to executable based on file extension
if ($ext eq pl)
{
# Source perl script - invoke perl interpreter
$path = \$^X\;
# Parameters include extra @INC directories and perl script
# @INC directories must not end in \ otherwise perl hangs
my $inc = ($cwd =~ /^(.*?)[\\]?$/) [0];
# The command includes the --run switch needed in main()
$parameters = -I . \$inc\ . \$fn\ --run;
}
elsif ($ext eq exe)
{
# Compiled perl script - invoke the compiled script
$path = \$fn\;
$parameters = ;
}
else
{
# Invalid file type?
die Can not install service for $fn,
file extension $ext not supported\n;
}
# Populate the service configuration hash
# The hash is required by Win32::Daemon::CreateService
my %srv_config = (
name = $srv_name,
display = $srv_name,
path =
Re: ActiveState announces ActivePerl 5.14.2
Congratulations~~ by the way, is MinGW built into this version? or I'd rather stay in 5.12. ;) On Fri, Oct 14, 2011 at 2:57 AM, Jan Dubois j...@activestate.com wrote: ActiveState is pleased to announce ActivePerl 5.14.2 build 1402, a complete, ready-to-install binary distributions of Perl. Builds for Windows, Mac OS X and Linux are made freely available. Builds for Solaris, HP-UX and AIX are available with ActivePerl Business Edition. For detailed information or to download these releases, see: http://www.activestate.com/activeperl What's new in ActivePerl ActivePerl 5.14 is now based on the 5.14.2 release. You can read about all the changes since Perl 5.14.1 in this perldelta document: http://docs.activestate.com/activeperl/5.14/lib/pods/perl5142delta.html Getting Started === Whether you're a first-time user or a long-time fan, our free resources will help you get the most from ActivePerl. Mailing list archives: http://code.activestate.com/lists/activeperl/ Supported Platforms === ActivePerl is available for the following platforms: - Windows/x86 (32-bit) - Windows/x64 (64-bit) (aka AMD64) - Mac OS X - Linux/x86 (32 bit) - Linux/x86_64 (64-bit) (aka AMD64) - Solaris/SPARC (32-bit and 64-bit) (Business Edition only) - Solaris/x86 (32-bit)(Business Edition only) - HP-UX/PA-RISC (32-bit)(Business Edition only) - AIX/PowerPC (32-bit)(Business Edition only) More information about the Business Edition can be found here: http://www.activestate.com/business-edition Custom builds are available in the Enterprise Edition: http://www.activestate.com/enterprise-edition Feedback Everyone is encouraged to participate in making Perl an even better language. For bugs related to ActiveState use: http://bugs.activestate.com/enter_bug.cgi?product=ActivePerlversion=1402 For bugs related directly to Perl please use the 'perlbug' utility. Enjoy! ___ ActivePerl mailing list activep...@listserv.activestate.com To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs ___ Perl-Win32-Users mailing list Perl-Win32-Users@listserv.ActiveState.com To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
Re: Non blocking keyboard
Good work! thanks for your sharing. ;)
On Fri, Oct 14, 2011 at 7:37 AM, Barry Brevik bbre...@stellarmicro.comwrote:
Last week I had posted a query about getting keyboard input in a non
blocking way.
I received several replies, so I thought I would post back the code I
developed which seems to work.
This is not the code I will end up using; it is more like a proof of
concept program.
use strict;
use warnings;
use Win32::Console;
my $signame = '';
my $havebrk = 0;
$SIG{INT} = sub {$signame = $_[0]; $havebrk = 1;};# CTRL-C.
$SIG{BREAK} = sub {$signame = $_[0]; $havebrk = 1;};# CTRL-BREAK,
CTRL-ScrollLock.
my $STDIN = new Win32::Console(STD_INPUT_HANDLE);
$STDIN - Mode(ENABLE_PROCESSED_INPUT);
while (1)
{
if ($STDIN-GetEvents())
{
# We do this inner loop here to make shure that we read
# all of the characters in the key buffer.
while ($STDIN-GetEvents())
{
# Read console event.
my @input = $STDIN-Input();
# input[0] is the event type- 1 for keyboard, 2 for mouse. So what
is 0 for?
if (defined $input[0] and $input[0] == 1)
{
my ($eventType, $keyState, $keyCount, $keyCode, $scanCode,
$keyValue, $keyFlags) = @input;
if ($havebrk) {die User termination on signal $signame.\n\n;}
# KeyState of 1 means key down.
if ($keyState == 1)
{
if ($keyValue == 0x00)
{
# Most control keys fall in here.
if ($keyCode == 16) {print \nSHIFT key pressed.\n;}
if ($keyCode == 17) {print \nCTRL key pressed.\n;}
if ($keyCode == 18) {print \nALT key pressed.\n;}
if ($keyCode == 19) {print \nBREAK key pressed.\n;}
if ($keyCode == 20) {print \nCAPS LOCK key pressed.\n;}
if ($keyCode == 33) {print \nPG UP key pressed.\n;}
if ($keyCode == 34) {print \nPG DN key pressed.\n;}
if ($keyCode == 35) {print \nEND key pressed.\n;}
if ($keyCode == 36) {print \nHOME key pressed.\n;}
if ($keyCode == 37) {print \nLEFT ARROW key pressed.\n;}
if ($keyCode == 38) {print \nUP ARROW key pressed.\n;}
if ($keyCode == 39) {print \nRIGHT ARROW key pressed.\n;}
if ($keyCode == 40) {print \nDOWN ARROW key pressed.\n;}
if ($keyCode == 45) {print \nINS key pressed.\n;}
if ($keyCode == 46) {print \nDEL key pressed.\n;}
if ($keyCode == 91) {print \nLEFT WINDOWS key
pressed.\n;}
if ($keyCode == 92) {print \nRIGHT WINDOWS key
pressed.\n;}
if ($keyCode == 93) {print \nCONTEXT key pressed.\n;}
if ($keyCode == 112) {print \nF1 pressed.\n;}
if ($keyCode == 113) {print \nF2 pressed.\n;}
if ($keyCode == 114) {print \nF3 pressed.\n;}
if ($keyCode == 115) {print \nF4 pressed.\n;}
if ($keyCode == 116) {print \nF5 pressed.\n;}
if ($keyCode == 117) {print \nF6 pressed.\n;}
if ($keyCode == 118) {print \nF7 pressed.\n;}
if ($keyCode == 119) {print \nF8 pressed.\n;}
if ($keyCode == 120) {print \nF9 pressed.\n;}
if ($keyCode == 121) {print \nF10 pressed.\n;}
if ($keyCode == 122) {print \nF11 pressed.\n;}
if ($keyCode == 123) {print \nF12 pressed.\n;}
if ($keyCode == 144) {print \nNUM LOCK pressed.\n;}
if ($keyCode == 145) {print \nSCROLL LOCK pressed.\n;}
}
elsif ($keyValue = 0x7f)
{
# High line draw chars etc fall in here, however
# I was never able to get it to trigger.
print High char pressed.\n;
}
else
{
# *Almost* Everything else is a printable ASCII character.
if($keyValue == 8) {print BACKSPACE key pressed.\n;}
elsif ($keyValue == 9) {print TAB key pressed.\n;}
elsif ($keyValue == 13) {print ENTER key pressed.\n;}
elsif ($keyValue == 27) {print ESC key pressed.\n;}
else
{
# When here, presumably a printable character has been
pressed.
my $keyChr = chr($keyValue);
print \nChar pressed: $keyChr\n;
}
}
}
# KeyState of 0 means that a key was released.
elsif ($keyState == 0)
{
if ($keyValue == 0x00)
{
if ($keyCode == 16) {print SHIFT key released.\n\n;}
if ($keyCode == 17) {print CTRL key released.\n\n;}
if ($keyCode == 18) {print ALT key released.\n\n;}
if ($keyCode == 19) {print BREAK key released.\n\n;}
if ($keyCode == 20) {print CAPS LOCK key released.\n\n;}
if ($keyCode == 33) {print PG UP key released.\n\n;}
if ($keyCode == 34) {print PG DN key released.\n\n;}
if ($keyCode == 35) {print END key released.\n\n;}
Re: Setting file server time
Use WMI to query and set time and date on remote systems. You may need to
adjust privileges for your account to set time/date on the remote machine.
use Win32::OLE qw(in);
my $datetime = Win32::OLE-new(WbemScripting.SWbemDateTime) or die;
my $machine = shift @ARGV or .;
$machine =~ s/^[\\\/]+//;
my $wmiservices =
Win32::OLE-GetObject(winmgmts:{impersonationLevel=impersonate,(security)}//$machine)
or die;
foreach my $os ( in( $wmiservices-InstancesOf(Win32_OperatingSystem)))
{
print Last Boot Time:.$os-{LastBootUpTime}.\n;
print Current time:.$os-{LocalDateTime}.\n;
$datetime-{Value} = $os-{LocalDateTime};
printf( Current Time: %02d-%02d-%04d at %02d:%02d:%02d\n,
$datetime-{Month}, $datetime-{Day}, $datetime-{Year}, $datetime-{Hours},
$datetime-{Minutes}, $datetime-{Seconds} );
print Setting time + 2 hours:;
$datetime-{Hours} += 2;
printf( Current Time: %02d-%02d-%04d at %02d:%02d:%02d\n,
$datetime-{Month}, $datetime-{Day}, $datetime-{Year}, $datetime-{Hours},
$datetime-{Minutes}, $datetime-{Seconds} );
print \tHard value: $datetime-{Value}\n;
$Result = $os-SetDateTime($datetime-{Value});
print Result: $Result\n;
}
On Wed, Sep 28, 2011 at 4:04 AM, william.hoo...@l-3com.com wrote:
I've used Win32-OLE to start/execute processes on remote computers. In
this scenario you could use Win32-OLE to call time
-Original Message-
From: perl-win32-users-boun...@listserv.activestate.com
[mailto:perl-win32-users-boun...@listserv.activestate.com] On Behalf Of
Barry Brevik
Sent: Monday, September 26, 2011 8:24 PM
To: Tobias Hoellrich; Howard Tanner;
perl-win32-users@listserv.ActiveState.com
Subject: RE: Setting file server time
Yes NTP. Well, if the guy had it setup right it would work, but no. So I
had to create an internet time server bot (with a little help) which
sets the local machine time. I was hoping to employ a Win32-only
solution to then set the domain controller rather than spawn one of the
pstools (I am familiar with them).
-Original Message-
From: perl-win32-users-boun...@listserv.activestate.com
[mailto:perl-win32-users-boun...@listserv.activestate.com] On
Behalf Of Tobias Hoellrich
Sent: Monday, September 26, 2011 4:44 PM
To: Howard Tanner; perl-win32-users@listserv.ActiveState.com
Subject: RE: Setting file server time
Since the advent of NTP on the Windows platforms I don't
remember the last time there was a need to set the time manually :-)
Thanks- T
-Original Message-
From: Howard Tanner [mailto:tan...@optonline.net]
Sent: Monday, September 26, 2011 5:26 PM
To: Tobias Hoellrich; 'Barry Brevik';
perl-win32-users@listserv.ActiveState.com
Subject: RE: Setting file server time
NET TIME was my first thought too, but it only allows you to
set your time to that of another machine.
___
Perl-Win32-Users mailing list
Perl-Win32-Users@listserv.ActiveState.com
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
___
Perl-Win32-Users mailing list
Perl-Win32-Users@listserv.ActiveState.com
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
___
Perl-Win32-Users mailing list
Perl-Win32-Users@listserv.ActiveState.com
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
___
Perl-Win32-Users mailing list
Perl-Win32-Users@listserv.ActiveState.com
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
