/usr/share/perl5/Daemon/Generic/While1.pm is in libdaemon-generic-perl 0.84-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | package Daemon::Generic::While1;
use strict;
use warnings;
use Carp;
require Daemon::Generic;
require POSIX;
require Exporter;
our @ISA = qw(Daemon::Generic Exporter);
our @EXPORT = @Daemon::Generic::EXPORT;
our $VERSION = 0.84;
sub newdaemon
{
local($Daemon::Generic::caller) = caller() || 'main';
local($Daemon::Generic::package) = __PACKAGE__;
Daemon::Generic::newdaemon(@_);
}
sub gd_setup_signals
{
my ($self) = @_;
$SIG{HUP} = sub {
$self->{gd_sighup} = time;
};
my $child;
$SIG{INT} = sub {
$self->{gd_sigint} = time;
#
# We'll be getting a SIGTERM in a bit if we're not dead, so let's use it.
#
$SIG{TERM} = sub {
$self->gd_quit_event();
kill(15, $child) if $child; # if we're still alive, let's stay that way
};
};
}
sub gd_sleep
{
my ($self, $period) = @_;
croak "Sleep period must be defined" unless defined $period;
my $hires;
if ($period*1000 != int($period*1000)) {
$hires = 1;
require Time::HiRes;
import Time::HiRes qw(time sleep);
}
my $t = time;
while (time - $t < $period) {
return if $self->{gd_sigint};
return if $self->{gd_sighup};
if ($hires) {
my $p = (time - $t < 1)
? time - $t
: 1;
sleep($p);
} else {
sleep(1);
}
}
}
sub gd_run
{
my ($self) = @_;
while(1) {
if ($self->{gd_sigint}) {
$self->{gd_sigint} = 0;
$self->gd_quit_event();
}
if ($self->{gd_sighup}) {
$self->{gd_sighup} = 0;
$self->gd_reconfig_event();
}
$self->gd_run_body();
}
}
sub gd_reconfig_event
{
my $self = shift;
print STDERR "Reconfiguration requested\n";
$self->gd_postconfig($self->gd_preconfig());
}
sub gd_quit_event
{
print STDERR "Quitting...\n";
exit(0);
}
sub gd_run_body { die "must override gd_run_body()" }
1;
=head1 NAME
Daemon::Generic::While1 - Daemon framework with default while(1) loop
=head1 SYNOPSIS
@ISA = qw(Daemon::Generic::While1);
sub gd_run_body {
# stuff
}
=head1 DESCRIPTION
This is a slight variation on L<Daemon::Generic>: a default
C<gd_run()> provided. It has a while(1) loop that calls
C<gd_run_body()> over and over. It checks for reconifg and
and terminate events and only actions them between calls
to C<gd_run_body()>.
Terminate events will be forced through after
C<$Daemon::Generic::force_quit_delay> seconds if
C<gd_run_body()> doesn't return quickly enough.
=head1 SUBCLASS METHODS REQUIRD
The following method is required to be overridden to subclass
Daemon::Generic::While1:
=over 15
=item gd_run_body()
This method will be called over and over. This method should
include a call to C<sleep(1)> (or a bit more). Reconfig events
will not interrupt it. Quit events will only interrupt it
after 15 seconds.
=back
=head1 ADDITIONAL METHODS
The following additional methods are available for your use
(as compared to L<Daemon::Generic>):
=over 15
=item gd_sleep($period)
This will sleep for C<$period> seconds but in one-second
intervals so that if a SIGINT or SIGHUP arrives the sleep
period can end more quickly.
Using this makes it safe for C<gd_run_body()> to sleep for
longer than C<$Daemon::Generic::force_quit_delay> seconds
at a time.
=back
=head1 ADDITIONAL MEMBER DATA
The following additional bits of member data are defined:
=over 15
=item gd_sigint
The time at which an (unprocessed) SIGINT was received.
=item gd_sighup
The time at which an (unprocessed) SIGHUP was received.
=back
=head1 LICENSE
Copyright (C) 2006-2010 David Muir Sharnoff <muir@idiom.com>.
Copyright (C) 2011 Google, Inc.
This module may be used and distributed on the same terms
as Perl itself.
|