package PhexProxy::Daemon;

#########################################
##### Author:		Lincoln Stein
##### CopyRight:	GPL
##### LastModified	11.07.2006
##### Function:		Daemon Fähigkeiten des Servers		
##### Todo:			
########################################

use strict;
use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION);

use POSIX qw(:signal_h setsid WNOHANG);
use Carp 'croak','cluck';
use Carp::Heavy;
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);
my $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 "Can't fork" unless defined (my $child = fork);
  exit 0 if $child;    # parent dies;
  POSIX::setsid();     # become session leader
  open(STDIN,"</dev/null");
  open(STDOUT,">/dev/null");
  open(STDERR,">&STDOUT");
  $CWD = getcwd;       # remember working directory
  chdir '/';           # change working directory
  umask(0);            # forget file mode creation mask
  $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 "Can't get uid for $user\n";
  my $gid = getgrnam($group) or die "Can't get gid for $group\n";
  $) = "$gid $gid";
  $( = $gid;
  $> = $uid;   # change the effective UID (but not the real UID)
};

sub launch_child {
  my $callback = shift;
  my $home     = shift;
  my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP);
  sigprocmask(SIG_BLOCK,$signals);  # block inconvenient signals
  log_die("Can't fork: $!") 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);  # unblock signals
  return $child;
};

sub prepare_child {
  my $home = shift;
  if ($home) {
    local($>,$<) = ($<,$>);   # become root again (briefly)
    chdir  $home || croak "chdir(): $!";
    chroot $home || croak "chroot(): $!";
  };
  $< = $>;  # set real UID to effective UID
};

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;
  # wait until all the children die
  sleep while %CHILDREN;
};

sub do_relaunch {
  $> = $<;  # regain privileges
  chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!;
  croak "bad program name" 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 "Couldn't exec: $!";
};

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('',@_) || "Something's wrong";
  my ($pack,$filename,$line) = caller(1);
  $msg .= " at $filename line $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) {  # oops.  pid file already exists
    my $fh = IO::File->new($file) || return;
    my $pid = <$fh>;
    croak "Invalid PID file" unless $pid =~ /^(\d+)$/;
    croak "Server already running with PID $1" if kill 0 => $1;
    cluck "Removing PID file for defunct server process $pid.\n";
    croak"Can't unlink PID file $file" unless -w $file && unlink $file;
  };
  return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644)
    or die "Can't create $file: $!\n";
};

END { 
  $> = $<;  # regain privileges
  unlink $pidfile if defined $pid and $$ == $pid 
};

1;
__END__