Perl Windows Service - запускается только один раз - PullRequest
0 голосов
/ 26 декабря 2018

У меня есть следующий код, который я использую для понимания создания службы Windows с Perl.Работают следующие части: установить, удалить, запустить, остановить, продолжить, приостановить, но секция запуска вызывается только один раз.Может кто-нибудь взглянуть и сказать мне, что мне не хватает?Я попытался зарегистрироваться для таймера, но это не вызывается вообще.Я пробовал это на нескольких разных машинах (Windows 7 и 10), и я получаю одинаковое поведение.

use Win32::Daemon;
use Getopt::Long;

Win32::Daemon::RegisterCallbacks( {
    start       =>  \&Callback_Start,
    running     =>  \&Callback_Running,
    stop        =>  \&Callback_Stop,
    pause       =>  \&Callback_Pause,
    continue    =>  \&Callback_Continue,
} );

my %Context = (
    last_state => SERVICE_STOPPED,
    start_time => time(),
    count => 0,
);

my %opt;
GetOptions (
    \%opt,   
    "install",
    "remove",
);

my @currDir = split /\//, $0;
my $script = $0;
my $scriptPath = ".";

if (scalar @currDir > 1)
{
    $script = pop @currDir;
    $scriptPath = join "/", @currDir;
    chdir( $scriptPath );
}

my %serviceConfig = (

    name            => 'steveg',
    display         => 'Steve Service',
    description     => 'Debugging',
    machine         => '',
    path            => $^X,
    parameters      => '"C:\source\perl\steveService.pl"',
);

if( $opt { install } )
{
    &installService();
    exit();
}
elsif( $opt { remove } )
{
    &removeService();
    exit();
}

sub installService
{
    # installs the win32 service daemon
    # ---------------------------------
    if( Win32::Daemon::CreateService( \%serviceConfig ) )
    {
        debug( 'The service [%s] was successfully installed', $serviceConfig { display } );
    }
    else
    {
        debug( 'Failed to install the service [%s]: %s',
            $serviceConfig { display },
            GetError() );
    }
}

# ====================================================================
sub removeService
{
    # removes the win32 service daemon
    # --------------------------------
    if( Win32::Daemon::DeleteService( $serviceConfig { name } ) )
    {
        debug( 'The service [%s] was successfully removed', $serviceConfig { display } );
    }
    else
    {
        debug( 'Failed to remove the service [%s]: %s',
            $serviceConfig { display },
            GetError() );
    }
}


Win32::Daemon::StartService( \%Context, 2000 );

sub Callback_Running
{
    my( $Event, $Context ) = @_;

    if( SERVICE_RUNNING == Win32::Daemon::State() )
    {        
        $Context -> { count }++; 
        debug ($Context->{count});  
    }
}

sub Callback_Start
{
    my( $Event, $Context ) = @_;
    # Initialization code
    debug ("Starting");

    $Context->{last_state} = SERVICE_RUNNING;
    Win32::Daemon::State( SERVICE_RUNNING );
}

sub Callback_Pause
{
    my( $Event, $Context ) = @_;
    $Context->{last_state} = SERVICE_PAUSED;
    debug ("Paused");
    Win32::Daemon::State( SERVICE_PAUSED );
}

sub Callback_Continue
{
    my( $Event, $Context ) = @_;
    $Context->{last_state} = SERVICE_RUNNING;
    debug ("Continuing");
    Win32::Daemon::State( SERVICE_RUNNING );
}

sub Callback_Stop
{
    my( $Event, $Context ) = @_;
    $Context->{last_state} = SERVICE_STOPPED;
    Win32::Daemon::State( SERVICE_STOPPED );
    debug ("Stopping");
    # We need to notify the Daemon that we want to stop callbacks and the service.
    Win32::Daemon::StopService();
}

sub debug
{
    my ($fmt, @data) = @_;
    my $message = sprintf $fmt, @data;
    open( FILE, ">>c:/temp/perlService.log" );
    print FILE "[" .localtime . "]: 2.1: $message\n";
    close( FILE );
    if (-t STDOUT && -t STDIN)
    {
        print "$message\n";
    }

}

** Обновление.Это было использование dwimp Perl.Если я попытаюсь использовать Strawberry Perl, я даже не смогу запустить сервис.Я получаю следующую ошибку.

Неопределенная подпрограмма & Win32 :: Daemon :: SERVICE_STOPPED, вызванная по C: \ source \ perl \ rtNVMService.pl, строка 85.

** Активный Perl запустится и напечатаетодин раз, но больше ничего.Кроме того, я не могу остановиться, продолжить или сделать паузу с ActivePerl.

Настолько расстраивает, что я могу получить так много разных вариантов поведения с одним и тем же фрагментом кода.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...