Didn't know that one. Thanks.

Personally, i use the ActiveState development kit. Especially on windows, it takes out a lot of hassle when writing services and tray applets.

For my Maplat project, i wrote my own service start/stop/watchdog thingy. This is still only in my DarkPAN repository.

...what the hell. i'm just gonna release it right here (i just copy it from my repo, you may/will have to tweak it to your needs). One caution, though: You need a running memcached as well as the Maplat Framework installed.

Here's the main program:

#!/usr/bin/perl -w

# MAPLAT  (C) 2008-2009 Rene Schickbauer
# Developed under Artistic license
# for Magna Powertrain Ilz

use 5.010;
use strict;
use warnings;

BEGIN {
    unshift @INC, "/home/cavac/src/maplat_prodit/server";
    unshift @INC, "/home/cavac/src/maplat_prodit/lib";
    unshift @INC, "/home/cavac/src/maplat_logging/lib";
    unshift @INC, "/home/cavac/src/maplat_framework/lib";
}

use MaplatSVCLinux;
use XML::Simple;

use Maplat::Helpers::Logo;
our $APPNAME = "Maplat SVC";
our $VERSION = 0.995;
MaplatLogo($APPNAME, $VERSION);

our $isCompiled = 0;
if(defined($PerlApp::VERSION)) {
    $isCompiled = 1;
}

our $cycleStartTime = 0;

# ------------------------------------------
# MAPLAT - Service/Daemon for Linux
# ------------------------------------------

my $action = shift @ARGV;
if(($action ne "start" && $action ne "stop" && $action ne "reset")) {
    print "ARGV: " . $#ARGV . "\n";
    print("Usage:\n\tmaplat_svc_linux.pl [start|stop|reset] config.xml
+\n");
    exit(1);
}

my $configfile = shift @ARGV;
print "Loading config file $configfile\n";

my $config = XMLin($configfile,
                    ForceArray => ['module', 'run'],);

if(defined($config->{basedir})) {
    print "Changing dir to " . $config->{basedir} . "\n";
    chdir $config->{basedir};
}

my @modlist = @{$config->{module}};
my $svcserver = new MaplatSVCLinux(0,
                              $config->{basedir},
                              $config->{memhserver},
                              $config->{memhnamespace},
                              $APPNAME,
                              $VERSION,
                              $isCompiled,
                              );

if($action eq "stop") {
    my $status = $svcserver->getServerStatus();
    if($status eq "stopping") {
        print "STOP already requested\n";
        exit(0);
    } elsif($status eq "stopped") {
        print "Service not running\n";
        exit(0);
    }
    $svcserver->requestStop();
    print "STOP requested\n";
    while(1) {
        $status = $svcserver->getServerStatus();
        last if($status eq "stopped");
        print "Waiting for service to stop...\n";
        sleep(1);
    }
    print "Service shut down.\n";
    exit(0);
}

if($action eq "reset") {
    print "'Manually' resetting service status fields...\n";
    #$svcserver->requestStop();
    $svcserver->setServerStatus("stopped");
    sleep(5);
    my $status = $svcserver->getServerStatus();
    if($status eq "stopped") {
        print "Reset seems to have worked.\n";
    } else {
        print "Failed: Got back status '$status'\n";
    }
    exit(0);
}

# Configure run-once scripts
$svcserver->setServerStatus("starting");
if(defined($config->{startup}->{run})) {
        foreach my $script (@{$config->{startup}->{run}}) {
                $svcserver->configure_startup($script);
        }
}
if(defined($config->{shutdown}->{run})) {
        foreach my $script (@{$config->{shutdown}->{run}}) {
                $svcserver->configure_shutdown($script);
        }
}

foreach my $module (@modlist) {
        $svcserver->configure_module($module);
}
        
$svcserver->endconfig();

$svcserver->setServerStatus("running");
my $loopcount = 0;
while (!$svcserver->shouldStop()) {
    my $workCount = $svcserver->work();
    sleep(1);

    # Just in case - set our status to running as long as the main loo
+p
    # runs. This helps prevent some troubles
    $svcserver->setServerStatus("running");

    $loopcount++;
    if($loopcount == 100) {
        print "...ping...\n";
        $loopcount = 0;
    }
}
    
$svcserver->setServerStatus("stopping");
$svcserver->shutdown;
$svcserver->setServerStatus("stopped");
[download]

And the package that does the actual work:

package MaplatSVCLinux;
use strict;
use warnings;

use Maplat::Helpers::Cache::Memcached;
use Maplat::Helpers::BuildNum;
use Unix::PID;

sub new {
    my ($class, $isService, $basePath, $memhserver, $memhnamespace,
        $APPNAME, $VERSION, $isCompiled) = @_;
    my $self = bless {}, $class;
    
    $self->{isService} = $isService;
    
    $basePath =~ s/\//\\/g; # Convert to Win32 Path
    $self->{basePath} = $basePath;
    
    if($memhserver ne "none") {
        my $memd;
        my $memd_loaded = 0;
        # Decide which Memcached module we want to use
        # First, we try the festest one, then the standard
        # one and if everything fails we use our own
        if(eval('require Cache::Memcached::Fast')) {
            print "    Cache::Memcached::Fast available.\n";
            $memd = new Cache::Memcached::Fast {
                            servers   => [ $memhserver ],
                            namespace => $memhnamespace . "::",
                            connect_timeout  => 0,
                        };
            $memd_loaded = 1;
        } elsif(eval('require Cache::Memcached')) {
            print "    No Cache::Memcached::Fast ... falling back to C
+ache::Memcached\n";
            $memd = new Cache::Memcached {
                            servers   => [ $memhserver ],
                            namespace => $memhnamespace . "::",
                            connect_timeout  => 0,
                        };
            $memd_loaded = 1;
        } else {
            print "    No Cache::Memcached* available ... will try to 
+use MaplatHelpers::Cache::Memcached\n";
        }
    
        # Check if the selected Memcached lib is working correctly
        my $key = "test_" . int(rand(10000)) . "_" . int(rand(10000));
        my $val = "test_" . int(rand(10000)) . "_" . int(rand(10000));
        my $newval;
        if($memd_loaded) {
            $memd->set($key, $val);
            $newval = $memd->get($key);
        }
        if(!defined($newval) || $newval ne $val) {
            if($memd_loaded) {
                print "    Selected Memcached client lib is broken - f
+alling back to MaplatHelpers::Cache::Memcached\n";
            }
            $memd = new MaplatHelpers::Cache::Memcached {
                            servers   => [ $memhserver ],
                            namespace => $memhnamespace . "::",
                            connect_timeout  => 0,
                        };
            $memd->set($key, $val);
            $newval = $memd->get($key);
            if(!defined($newval) || $newval ne $val) {
                die("Maplat Memcached client lib is also broken - givi
+ng up!"); 
            } else {
                $memd->delete($key);
            }
        } else {
            $memd->delete($key);
        }
    
    
    
        print "    Selected Memcached library seems to be working. Goo
+d!\n";
        $self->{memd} = $memd;
        
        $self->memhset("VERSION::" . $APPNAME, $VERSION);
        $self->memhset("BUILD::" . $APPNAME, readBuildNum(undef, $isCo
+mpiled));
        $self->memhdelete("StopSVC");
        $self->{is_configured} = 0;
    }
    
    return $self;
}

sub requestStop {
    my ($self) = @_;
    
    my $tmp = 1;
    $self->memhset("StopSVC", $tmp);
}

sub shouldStop {
    my ($self) = @_;
    
    my $stop = $self->memhget("StopSVC");
    if(!defined($stop) || $stop != 1){
        return 0;
    } else {
        return 1;
    }
    
}

sub setServerStatus {
    my ($self, $status) = @_;

    $self->memhset("SVCRunningStatus", $status);
}

sub getServerStatus {
    my ($self) = @_;
    
    my $status = $self->memhget("SVCRunningStatus");
    if(!defined($status)){
        return "stopped";
    } else {
        return $status;
    }
    
}

sub startconfig {
    my ($self) = @_;
    
    $self->{apps} = ();
    $self->{startup_scripts} = ();
    $self->{shutdown_scripts} = ();
}

sub configure_module {
    my ($self, $module) = @_;
    
    print "Configuring module " . $module->{description} . "...\n";
    $module->{handle} = undef;
    
    my $fullapp = $module->{app};
    $module->{app} = $fullapp;

    my $fullconf = $module->{conf};
    $module->{conf} = $fullconf;
    
    
    push @{$self->{apps}}, $module;
}

sub configure_startup {
    my ($self, $command) = @_;
    
    $command =~ s/\//\\/g;
    push @{$self->{startup_scripts}}, $command;
}

sub configure_shutdown {
    my ($self, $command) = @_;
    
    $command =~ s/\//\\/g;
    push @{$self->{shutdown_scripts}}, $command;
}

sub endconfig {
    my ($self) = @_;
    
    # "Don't fear the Reaper"
    $SIG{CHLD} = 'IGNORE';
    
    foreach my $script (@{$self->{startup_scripts}}) {
        $self->run_script($script);
    }
    print "Startup scripts complete\n";
    
    foreach my $app (@{$self->{apps}}) {
        $self->start_app($app);
    }
    print "Initial apps startup complete\n";
    $self->{shutdown_complete} = 0;
    $self->{is_configured} = 1;
    
}

sub work {
    my ($self) = @_;
    
    my $workCount = 0;
    
    foreach my $app (@{$self->{apps}}) {
        if(!$self->check_app($app)) {
            print "*** App " . $app->{description} . " FAILED! ***\n"
        }
        
        $workCount++;
    }    
    
    return $workCount;
    
}

sub shutdown {
    my ($self) = @_;
    
    if($self->{is_configured} == 1) {
        print "Shutdown started.\n";
        
        foreach my $app (@{$self->{apps}}) {
            $self->stop_app($app);
        }
        
        print "Apps shut down.\n";
        
        foreach my $script (@{$self->{shutdown_scripts}}) {
            $self->run_script($script);
        }
        print "Shutdown scripts complete\n";
    }
    $self->{shutdown_complete} = 1;
    return;
}

sub DESTROY {
    my ($self) = @_;
    
    if(!$self->{shutdown_complete}) {
        $self->shutdown();
    }
}

sub check_app {
    my ($self, $app) = @_;
    
    if(!defined($app->{handle})) {
        return $self->start_app($app);
    }
    
    my $checker = Unix::PID->new();
    
    # First, check if the process exited
    if(!$checker->is_pid_running($app->{handle})) {
        # Process exited, so, restart
        print "Process exit detected: " . $app->{description} . "!n";
        return $self->start_app($app);
    }
    
    if(!defined($app->{lifetick}) || $app->{lifetick} == 0) {
        return 1;
    } else {
        # Process itself is still running, so check its lifetick
        # to see if it hangs
        my $pid = $app->{handle};
        my $apptick = $self->memhget("LIFETICK::" . $pid);
        if(defined(!$apptick)) {
            #print "Apptick not set for " . $app->{description} . "!\n
+";
            return 1;
        } elsif($apptick == 0) {
            # Client requested a temporary suspension of lifetick hand
+ling
            return 1;
        }
        my $tickage = time - $apptick;
        if($tickage > $app->{lifetick}) {
            # Stale lifetick
            print "Stale Lifetick detected: " . $app->{description} . 
+"!\n";
            $self->stop_app($app);
            return $self->start_app($app);
        } else {
            return 1;
        }
        
    }
    
}

sub start_app {
    my ($self, $app) = @_;
    
    my $pid = fork();

    if($pid) {
        #parent
        print "Forked " . $app->{app} . " has PID $pid\n";
        $app->{handle} = $pid;
        my $stime = time;
        $self->memhset("LIFETICK::" . $pid, $stime);
    } else {
        # Child
        exec($app->{app} . " " . $app->{conf}) or die("Can't exec");
        print "Child done\n";
        exit(0);
    }
}

sub stop_app {
    my ($self, $app) = @_;
    
    if(defined($app->{handle}) && $app->{handle}) {
        my $pid = $app->{handle};
        print "Killing app " . $app->{description} . " with PID $pid..
+.\n";
        kill 15, $pid; # SIGTERM
        sleep(2);
        kill 9, $pid;  #SIGKILL
        $app->{handle} = undef;
        print "...killed.\n";
        $self->memhdelete("LIFETICK::" . $pid);
    } else {
        print "App " . $app->{description} . " already killed\n";
    }
    
}

sub run_script {
    my ($self, $command) = @_;
    
    print "Running command '$command':\n";
    my @lines = `$command`;
    foreach my $line (@lines) {
    chomp $line;
    print ":: $line\n";
    }
                
    return 1;
}

sub memhget {
    my ($self, $key) = @_;
    
    return if(!defined($self->{memd}));
    
    $key = $self->memhsanitize_key($key);
    
    return $self->{memd}->get($key);
}

sub memhset {
    my ($self, $key, $data) = @_;
    
    return if(!defined($self->{memd}));
    
    $key = $self->memhsanitize_key($key);
    
    return $self->{memd}->set($key, $data);
}

sub memhdelete {
    my ($self, $key) = @_;
    
    return if(!defined($self->{memd}));
    
    $key = $self->memhsanitize_key($key);
    
    return $self->{memd}->delete($key);
}

sub memhsanitize_key {
    my ($self, $key) = @_;
    
    # Certain chars are not allowed in keys for whatever reason.
    # This *should* be handled by the Cache::Memcached module, but isn
+'t
    # We handle this by substituting them with a tripple underline
    
    $key =~ s/\ /___/go;
    
    return $key;
}

1;
[download]

All configuration is done in a simple XML file (which is why i use XML::Simple... harhar):

<maplatsvc>
    
    <basedir>/home/cavac/src/maplat_prodit/server</basedir>
    <memhserver>127.0.0.1:11211</memhserver>
    <memhnamespace>RBSMem</memhnamespace>
    
    
    <!--
    <startup>
        <run>start.sh</run>
    </startup>
    
    <shutdown>
        <run>shut.sh</run>
        <run>shut.sh</run>
    </shutdown>
    -->
    
    
    <module>
        <description>WebGui</description>
        <app>perl webgui_cmd.pl</app>
        <conf>configs/rbswebgui.xml</conf>
        <lifetick>0</lifetick>
    </module>

    <module>
        <description>WebGuiSSL</description>
        <app>perl webgui_cmd.pl</app>
        <conf>configs/rbswebgui_ssl.xml</conf>
        <lifetick>0</lifetick>
    </module>
    
    <module>
        <description>RBS Worker</description>
        <app>perl worker_cmd.pl</app>
        <conf>configs/rbsworker.xml</conf>
        <lifetick>120</lifetick>
    </module>

    <module>
        <description>Uncritical Worker</description>
        <app>perl worker_cmd.pl</app>
        <conf>configs/uncriticalworker.xml</conf>
        <lifetick>600</lifetick>
    </module>

    <module>
        <description>TimeServer</description>
        <app>perl timeserver_cmd.pl</app>
        <conf></conf>
        <lifetick>60</lifetick>
    </module>
</maplatsvc>
[download]

The svc program does not detach itself from the command line, here's a sample script to start all services. Most of it's work is to set the correct path for my perl interpreter.

#!/bin/bash

# ActiveState Perl
export PATH=/home/cavac/bin/ActivePerl-5.12/site/bin:/home/cavac/bin/A
+ctivePerl-5.12/bin:$PATH
export MANPATH=/home/cavac/bin/ActivePerl-5.12/site/man:/home/cavac/bi
+n/ActivePerl-5.12/man:$MANPATH
# ActiveState PDK
export PATH=/home/cavac/bin/PDK/bin:$PATH
export MANPATH=/home/cavac/bin/PDK/share/man:$MANPATH
# ActiveState Komodo
export PATH=/home/cavac/bin/Komodo-5/bin:$PATH

cd /home/cavac/src/maplat_prodit/server
perl maplat_svc_linux.pl start configs/rbssvc.xml &>/dev/null &
echo MAPLAT Background startup initiated...
[download]

When you don't want to background (like in this example, when we stop all services), just neither redirect nor use '&':

#!/bin/bash

# ActiveState Perl
export PATH=/home/cavac/bin/ActivePerl-5.12/site/bin:/home/cavac/bin/A
+ctivePerl-5.12/bin:$PATH
export MANPATH=/home/cavac/bin/ActivePerl-5.12/site/man:/home/cavac/bi
+n/ActivePerl-5.12/man:$MANPATH
# ActiveState PDK
export PATH=/home/cavac/bin/PDK/bin:$PATH
export MANPATH=/home/cavac/bin/PDK/share/man:$MANPATH
# ActiveState Komodo
export PATH=/home/cavac/bin/Komodo-5/bin:$PATH

cd /home/cavac/src/maplat_prodit/server
perl maplat_svc_linux.pl stop configs/rbssvc.xml
[download]

Sorry, this scripts are currently not really documented. If there is a problem, just contact me here on PerlMonks. But so far, the code worked over 2 years without a hitch.