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
Re: Non blocking keyboard
Good work! thanks for your sharing. ;)
On Fri, Oct 14, 2011 at 7:37 AM, Barry Brevik wrote:
> 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";}
>
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 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=ActivePerl&version=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: 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, 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
