#!/usr/bin/perl
# -----------------------------------------------------------------------------
# - T i a r r a - :::bootstrap:::
# Copyright (c) 2008 Tiarra Development Team. All rights reserved.
# This is free software; you can redistribute it and/or modify it
#   under the same terms as Perl itself.
# -----------------------------------------------------------------------------
# $Id: tiarra 35566 2009-10-09 14:53:58Z topia $
# -----------------------------------------------------------------------------
require 5.008;
use strict;
use warnings;
use File::Basename;
use File::Spec;
use Carp;

sub follow_link {
    my ($file, $max_count, $die_on_max) = @_;

    $max_count = 40 unless defined $max_count;
    my ($count, @path) = 0, ();
    push(@path, $file);
    while (-l $file) {
	$file = File::Spec->rel2abs(readlink($file), dirname($file));
	push(@path, $file);
	if (++$count >= $max_count) {
	    if ($die_on_max) {
		carp 'Too many levels of symbolic links';
	    } else {
		last;
	    }
	}
    }
    return @path;
}

BEGIN {
    # untaint
    $0 =~ /^(.+)$/;
    my $self = $1;
    my @add_inc;

    foreach my $path (map dirname($_), reverse follow_link($1)) {
	unshift(@INC,
		map{ File::Spec->catdir($path, $_); } qw(main module));
	unshift(@add_inc, File::Spec->catdir($path, 'bundle'));
    }
    push(@INC, @add_inc);
}

# optional modules
use Tiarra::OptionalModules;
# 外部から呼べるオプションモジュールの存在チェック。
# (過去互換)
sub ipv6_enabled { Tiarra::OptionalModules->ipv6; }

use Tiarra::Resolver; # early initialization
use Tiarra::Encoding;
use Configuration;
use RunLoop;
use ModuleManager;
use ReloadTrigger;
use IO::Handle;
our $terminated = 0;

# version はバージョン番号
our $version = '0.1';

# based はベースにしている Tiarra のバージョン(パッケージまたは fork 時用)
our $based_version = '';

# short は短いバージョン番号。(CTCP-Version の返答に使われる)
our $short_version = '';


# オリジナル(based_version が未定義)ならば svnversion をチェックする。
&check_svnversion unless $based_version;
# short_version が未定義なら version の値を使う。
$short_version ||= $version;

&install_signal_handlers;

sub check_svnversion {
    use IO::File;
    my $svnversion = '.svnversion';
    my $svnrevision;

    foreach my $file (follow_link($0)) {
	my $dir = dirname($file);
	my $path = File::Spec->catfile($dir, $svnversion);
	my $fh = IO::File->new($path, 'r');
	if (defined $fh) {
	    $svnrevision = <$fh>;
	    chomp $svnrevision;
	} elsif (-e File::Spec->catdir($dir, '.svn')) {
	    (my $svndir = $dir) =~ s/'/'\''/;
	    do {
		# special cleanup for taint check
		$ENV{PATH} =~ /^(.*)$/;
		local $ENV{PATH} = $1;
		$svndir =~ /^(.*)$/;
		$svnrevision = (`svnversion --no-newline --committed $1` =~ /(\d+[MS]{0,2})$/)[0];
	    };
	}
	$version .= '+svn-' . $svnrevision if defined $svnrevision && length $svnrevision;
	return;
    }
}

sub help {
    print "\n";
    print "Usage: tiarra [--config=config-file] [options]\n";
    print "\n";
    print "options:\n";
    print "  --help           print this message\n";
    print "  --version        print version information\n";
    print "  --dumpversion    print version\n";
    print "  --show-env       print environment information\n";
    print "  --config=<file>  tiarra configuration file; default is 'tiarra.conf'\n";
    print "  --quiet          don't output any messages to stdout and stderr,\n";
    print "                   and move to background (runs as daemon)\n";
    print "  --no-fork        don't move to background when started in quiet mode\n";
    print "  --force-fork     (debugging option) force fork without quiet\n";
    print "  --debug          show debug information\n";
    print "  --make-password  prompt you a password to encrypt.\n";
    print "                   *Tiarra doesn't do its normal work with this option*\n";
    print "   -D<symbol>[=<string>]\n";
    print "                   treat as `\@define <symbol> <string>' is in the conf\n";
    print "\n";
    print "If you specify --config=- parameter,\n";
    print "Tiarra will read configuration from stdin(pipe).\n";
    print "  example:\n";
    print "      cat tiarra.conf | sed -e 's/Tiarra/arraiT/g' | ./tiarra --config=- --quiet\n";
    print "      gunzip -c tiarra.conf.gz | ./tiarra --config=-\n";
    print "\n";
}

sub make_password {
    eval 'use Crypt;';
    print "Tiarra encrypts your raw password to use it for config file.\n";
    print "\n";

    my $password = &find_option('make-password');
    if ($password eq "1") {
	eval 'use Term::ReadLine;';
	my $term = Term::ReadLine->new('tiarra');
	$password = $term->readline("Please enter raw password: ");
	print "\n";
    }
    print Crypt::encrypt($password)." is your encoded password.\n";
    print "Use this for the general/tiarra-password entry.\n";
}

sub find_option {
    my $option = shift;
    foreach my $arg (@ARGV) {
	if ($arg eq "--$option") {
	    return 1;
	} elsif ($arg =~ m/^--$option=(.+)$/) {
	    return $1;
	}
    }
    undef;
}

sub find_options {
    # $opt_regex: オプション名の正規表現。後方参照を一つだけ作る事。
    # 戻り値: ([$1, 値], ...)
    my $opt_regex = shift;
    grep {
	defined;
    } map {
	if (m/^--?$opt_regex=(.+)/) {
	    [$1, $2];
	}
	elsif (m/^--?$opt_regex$/) {
	    [$1, 1];
	}
	else {
	    undef;
	}
    } @ARGV;
}

sub main {
    if (&find_option('debug')) {
	eval q(sub debug_printmsg{printmsg('debug: '.shift)});
	eval q(sub debug_mode{1;});
	$SIG{__WARN__} = sub {
	    ::printmsg(Carp::longmess(@_));
	};
	$SIG{__DIE__} = sub {
	    die @_ if $_[0] =~ /^[Cc]ouldn't connect/;
	    die @_ if $_[0] =~ /^network\/.+:\s*Server replied/;
	    die(Carp::longmess(@_));
	}
    } else {
	eval q(sub debug_printmsg{});
	eval q(sub debug_mode{0;});
    }

    if (&find_option('help')) {
	&help;
	return 0;
    } elsif (&find_option('version')) {
	map { print "$_\n" } get_credit();
	return 0;
    } elsif (&find_option('dumpversion')) {
	print $version . "\n";
	return 0;
    } elsif (&find_option('show-env')) {
	map { print "$_\n" } get_env();
	return 0;
    } elsif (&find_option('make-password')) {
	&make_password;
	return 0;
    }

    foreach my $pp_define (&find_options(qr/D(.+?)/)) {
	&Configuration::Preprocessor::initial_define(@$pp_define);
    }

    my $conf_file = &find_option('config');
    if (!defined $conf_file) {
	if (-f 'tiarra.conf') {
	    $conf_file = 'tiarra.conf';
	} else {
	    &help;
	    return 2;
	}
    }

    my $quiet = &find_option('quiet');
    my $no_fork = &find_option('no-fork');
    my $force_fork = &find_option('force-fork');

    my $boot = sub  {
	eval {
	    RunLoop->shared_loop->run;
	}; if ($@) {
	    print STDERR "Tiarra aborted: $@\n";
	    return 98;
	} else {
	    print "Tiarra successfully finished.\n";
	}
    };

    my $print = $quiet ? sub {} : sub { print @_ };

    if (!$quiet) {
	foreach my $line (get_credit()) {
	    $print->($line,"\n");
	}
	$print->("\n");
    }

    do {
	local($|) = 1;

	if ($conf_file ne '-') {
	    $print->("Reading configuration from ${conf_file}... ");
	} else {
	    $conf_file = IO::Handle->new->fdopen(fileno(STDIN),'r');
	    $print->("Reading configuration from stdin... ");
	}

	if (!$quiet) {
	    Configuration->shared_conf->load($conf_file);
	} else {
	    eval {
		Configuration->shared_conf->load($conf_file);
	    }; if ($@) {
		die "an error occoured on config read: $@";
	    }
	}
	$print->("ok\n");
    };

    # quietモードならSTDIN, STDOUT, STDERRを閉じる。
    if ($quiet) {
	close STDIN;
	close STDOUT;
	close STDERR;
    }

    # quietモードであり、且つno-forkオプションが指定されなかったらfork。
    if ($force_fork || ($quiet && !$no_fork)) {
	## HACK
	if ($Tiarra::Resolver::use_threads) {
	    Tiarra::Resolver->shared->destruct(1);
	}
	my $child_pid = fork;
	if ($child_pid == 0) {
	    ## HACK
	    if ($Tiarra::Resolver::use_threads) {
		Tiarra::Resolver->shared->init;
	    }
	    return $boot->();
	} elsif (!defined $child_pid) {
	    print "Tiarra: fork() failed.\n";
	} else {
	    return 'FORKED';
	}
    } else {
	return $boot->();
    }
    return 0;
}

sub printmsg {
    # 文字コードはUTF-8でなければならない。
    my $msg = shift;
    local($|) = 1;
    if (!defined $msg) {
	$msg = '';
    }
    $msg =~ s/\n*$//s;

    # Configurationが読み込まれていない時に文字コード変換するとdie。
    eval {
	local $SIG{__DIE__} = 'IGNORE';
	local $SIG{__WARN__} = 'IGNORE';
	$msg = Tiarra::Encoding->new($msg,'utf8')->conv(
	    Configuration->shared_conf->get('general')->stdout_encoding);
    };

    my ($sec,$min,$hour,$day,$mon,$year) = localtime(time);
    $mon++;
    $year += 1900;

    #printf("[%02d/%02d/%04d %02d:%02d:%02d] %s\n",$mon,$day,$year,$hour,$min,$sec,$msg);
    #printf("[%02d/%02d %02d:%02d:%02d] %s\n",$mon,$day,$hour,$min,$sec,$msg);
    printf("[pid:$$ %04d/%02d/%02d %02d:%02d:%02d] %s\n",$year,$mon,$day,$hour,$min,$sec,$msg);
}

sub version {
    $short_version;
}

sub get_credit {
    return (
	(!$based_version ?
	     "- T i a r r a - :::version #${version}:::" :
		 ("- T i a r r a - :::version ${version}:::",
		  "                    based #${based_version}")
	    ),
	    "Copyright (c) 2008 Tiarra Development Team. All rights reserved.",
	    "This is free software; you can redistribute it and/or modify it",
	    "  under the same terms as Perl itself.");
}

sub get_env {
    use Config;
    my @lines;
    if (!$based_version) {
	push @lines, "- T i a r r a - :::version #${version}:::";
    } else {
	push @lines, "- T i a r r a - :::version ${version}:::";
	push @lines, "                    based #${based_version}";
    }
    push @lines, "Environment Information:";
    push @lines, "  - Perl $Config{version} built for $Config{archname}";
    push @lines, "Optional Modules:";
    push @lines, map "  $_", Tiarra::OptionalModules->repr_modules(&debug_mode);
    push @lines, "Bundle Modules:";
    foreach my $mod (qw(Unicode::Japanese enum)) {
	my $modfile = $mod . '.pm';
	$modfile =~ s|::|/|g;
	eval "require $mod;";
	push @lines, "  - $mod " .
	    ($INC{$modfile} ?
		 ($mod->VERSION . " (" .
		      ($INC{$modfile} =~ m|bundle/| ? "bundle" : "system") . ")") :
			  "(unknown; not loaded)");
    }
    push @lines, "Default Encoding Driver:   " . ref(Tiarra::Encoding->new);
    @lines;
}

sub install_signal_handlers {
    local $SIG{__WARN__} = sub {};
    foreach (qw(INT QUIT ABRT TERM)) {
	$SIG{$_} = \&handle_exit;
    }
    $SIG{HUP} = \&handle_reload;
    $SIG{USR1} = \&handle_conf_reload;
    $SIG{PIPE} = 'IGNORE';
}

sub handle_exit {
    my $signame = shift;
    printmsg("SIG$signame received.");
    &shutdown('Tiarra '.::version.": SIG$signame received; exit");
}

sub handle_reload {
    my $signame = shift;
    printmsg("SIG$signame received.");
    ReloadTrigger->reload_conf_if_updated;
    ReloadTrigger->reload_mods_if_updated;
}

sub handle_conf_reload {
    my $signame = shift;
    printmsg("SIG$signame received.");
    ReloadTrigger->reload_conf_if_updated;
}

sub shutdown {
    my $msg = shift;
    $msg = 'Tiarra '.::version.': shutting down...' if !defined $msg;
    ++$terminated;
    if ($terminated == 1) {
	printmsg("Shutting down... [$msg]");
	RunLoop->shared_loop->terminate($msg);
    } elsif ($terminated == 2) {
	printmsg("Second Terminate Request; Force Exit! [$msg]");
	# force
	print "cleanup ModuleManager...";
	ModuleManager->shared_manager->terminate;
	print "done.\n";
	print "cleanup TerminateManager...";
	Tiarra::TerminateManager->terminate('main');
	print "done.\n";
	exit;
    } else {
	printmsg("Third Terminate Request; Fatal Exit! [$msg]");
	# fatal
	exit;
    }
}

my $exitval = main;
&debug_mode && print "cleanup TerminateManager...";
if ($exitval eq 'FORKED') {
    $exitval = 0;
    Tiarra::TerminateManager->terminate('forked');
} else {
    Tiarra::TerminateManager->terminate('main');
}
&debug_mode && print "done.\n";
exit $exitval;
