package Daemon;
use strict;
use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION);
use POSIX qw(:signal_h setsid WNOHANG);
use Carp 'croak','cluck';
use Carp::Heavy; # jeli uywasz perla o wersji mniejszej ni 5.6 zastp t linie na use Carp;
use File::Basename;
use IO::File;
use Cwd;
use Sys::Syslog qw(:DEFAULT setlogsock);
require Exporter;

@EXPORT_OK = qw(init_server prepare_child kill_children 
 launch_child do_relaunch
 log_debug log_notice log_warn 
 log_die %CHILDREN);
@EXPORT = @EXPORT_OK;
@ISA = qw(Exporter);
$VERSION = '1.00';

use constant PIDPATH  => '/var/run';
use constant FACILITY => 'local0';
use vars qw(%CHILDREN);
my ($pid,$pidfile,$saved_dir,$CWD);

sub init_server {
  my ($user,$group);
  ($pidfile,$user,$group) = @_;
  $pidfile ||= getpidfilename();
  my $fh = open_pid_file($pidfile);
  become_daemon();
  print $fh $$;
  close $fh;
  init_log();
  change_privileges($user,$group) if defined $user && defined $group;
  return $pid = $$;
}

sub become_daemon {
  croak "NIe mona rozwidli" unless defined (my $child = fork);
  exit 0 if $child; # mier ojca;
  POSIX::setsid();  # zostaje liderem sesji
  open(STDIN,"</dev/null");
  open(STDOUT,">/dev/null");
  open(STDERR,">&STDOUT");
  $CWD = getcwd; # zapamitaj katalog roboczy
  chdir '/';  # zmie katalog roboczy
  umask(0);# wyzeruj maske uprawnie tworzenia pliku
  $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin';
  delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
  $SIG{CHLD} = \&reap_child;
}

sub change_privileges {
  my ($user,$group) = @_;
  my $uid = getpwnam($user)  or die "Nie mona pobra uid dla uytkownika $user\n";
  my $gid = getgrnam($group) or die "Nie mona pobra gid dla grupy $group\n";
  $) = "$gid $gid";
  $( = $gid;
  $> = $uid;# zmieniam efektywny UID (lecz nie rzeczywisty)
}

sub launch_child {
  my $callback = shift;
  my $home  = shift;
  my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP);
  sigprocmask(SIG_BLOCK,$signals);  # blokuj niedogodne sygnay
  log_die("NIe mona rozwidli: $!") unless defined (my $child = fork());
  if ($child) {
 $CHILDREN{$child} = $callback || 1;
  } else {
 $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
 prepare_child($home);
  }
  sigprocmask(SIG_UNBLOCK,$signals);  # odblokuj sygnay
  return $child;
}

sub prepare_child {
  my $home = shift;
  if ($home) {
 local($>,$<) = ($<,$>);# zosta uytkownikiem root 
 chdir  $home || croak "chdir(): $!";
 chroot $home || croak "chroot(): $!";
  }
  $< = $>;  # zamie rzeczywisty UID na efektywny
}

sub reap_child {
  while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
 $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE';
 delete $CHILDREN{$child};
  }
}

sub kill_children {
  kill TERM => keys %CHILDREN;
  # czekaj na zakoczenie wszystkich potomkw
  sleep while %CHILDREN;
}

sub do_relaunch {
  $> = $<;  # odzyskaj przywileje
  chdir $1 if $CWD =~ m!([./a-zA-Z0-9_-]+)!;
  croak "za nazwa programu" unless $0 =~ m!([./a-zA-Z0-9_-]+)!;

  my $program = $1;
  my $port = $1 if $ARGV[0] =~ /(\d+)/;
  unlink $pidfile;
  exec 'perl','-T',$program,$port or croak "Nie mona wykona: $!";
}

sub init_log {
  setlogsock('unix');
  my $basename = basename($0);
  openlog($basename,'pid',FACILITY);
  $SIG{__WARN__} = \&log_warn;
  $SIG{__DIE__}  = \&log_die;
}

sub log_debug  { syslog('debug',_msg(@_))  }
sub log_notice { syslog('notice',_msg(@_)) }
sub log_warn{ syslog('warning',_msg(@_))}
sub log_die {
  syslog('crit',_msg(@_)) unless $^S;
  die @_;
}
sub _msg {
  my $msg = join('',@_) || "Co jest nie tak";
  my ($pack,$filename,$line) = caller(1);
  $msg .= " w $filename linia $line\n" unless $msg =~ /\n$/;
  $msg;
}

sub getpidfilename {
  my $basename = basename($0,'.pl');
  return PIDPATH . "/$basename.pid";
}

sub open_pid_file {
  my $file = shift;
  if (-e $file) {  # plik pid juz istnieje
 my $fh = IO::File->new($file) || return;
 my $pid = <$fh>;
 croak "Niewaciwy plik PID" unless $pid =~ /^(\d+)$/;
 croak "Serwer dziaa z  PID $1" if kill 0 => $1;
 cluck "Usuwam pliki PID dla niedziaajcych procesw serwera $pid.\n";
 croak"Nie mona odczy pliku PID $file" unless -w $file && unlink $file;
  }
  return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644)
 or die "Nie mona utworzy $file: $!\n";
}

END { 
  $> = $<;  # odzyskaj przywileje
  unlink $pidfile if defined $pid and $$ == $pid 
}

1;
__END__