root/lang/perl/tiarra/trunk/tiarra @ 11043

#!/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$
# -----------------------------------------------------------------------------
require 5.006;
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 "  --config=<file>  tiarra configuration file; default is 'tiarra.conf'\n";
    print "  --quiet          don't output any messages to stdout and stderr\n";
    print "  --no-fork        don't move to background when started in quiet mode\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 $boot = sub  {
        eval {
            RunLoop->shared_loop->run;
        }; if ($@) {
            die "Tiarra aborted: $@\n";
        } 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 ($quiet && !$no_fork) {
        my $child_pid = fork;
        if ($child_pid == 0) {
            # 子プロセス
            $boot->();
        } elsif (!defined $child_pid) {
            print "Tiarra: fork() failed.\n";
        }
    } else {
        $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;
    push @lines, "Bundle Modules:";
    foreach my $mod (qw(Unicode::Japanese IO::Socket::INET6 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;
}

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...";
Tiarra::TerminateManager->terminate('main');
&debug_mode && print "done.\n";
exit $exitval;