#!/usr/bin/perl
#
#   set-language-env
#
#   This file is a part of the Debian language-env package.
#
#
# Copyright (C) 1998-2003 Tomohiro KUBOTA
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# On Debian GNU/Linux systems, the complete text of the GNU General
# Public License can be found in `/usr/share/common-licenses/GPL'.
#
#
#
#

use Getopt::Std;

# ----------- Initialization -------------
# $delimstart0 and $delimend0 are prepared
# for backward compatibility to user-ja,
# which is a precursor of language-env.
# ----------------------------------------
$delimstart0 = " ---- user-ja DON'T MODIFY THIS LINE!";
$delimend0   = " ---- user-ja end DON'T MODIFY THIS LINE!";
$delimstart = " ---- language-env DON'T MODIFY THIS LINE!";
$delimend   = " ---- language-env end DON'T MODIFY THIS LINE!";
$ID = $<;
$HOME = (getpwuid($ID))[7];
$LIB = "/usr/share/language-env";
$TMP = "/tmp/language-env-$$";
$THIS = '/usr/bin/set-language-env';
$BACKUPPOSTFIX = ".language-env-bak";
$SKEL = "/etc/skel";

getopts("l:dvhNsrcCRE");
if (!$opt_h) {
	print STDERR "Setting up users' native language environment\n";
	print STDERR "by modifying their dot-files.\n";
	print STDERR "Type \"set-language-env -h\" for help.\n\n";
} else {
	print STDERR "Print help message in your language...\n";
}
if ("$ID" eq "0" && !$opt_R && !$opt_E && !$opt_h) {
	print STDERR "The root user should not run set-language-env\n";
	print STDERR "because this modifies your dot-files.\n";
	print STDERR "If you surely want to run set-language-env,\n";
	print STDERR "invoke with \'-R\' or \'-E\' option.\n";
	exit(0);
}
if ($opt_E) {
	if ($HOME eq "/root") {
		$HOME = $SKEL;
	} else {
		print STDERR "Only root user can use -E option.\n";
		exit(0);
	}
}
if ($opt_d) {
	$Sub::DEFAULT=1;
}
if ($opt_r) {
	&remove_setting();
	exit(0);
}

# ------------ Language List -------------
# Making a list of supported list from
# support.<language>.pl files.
# ----------------------------------------
opendir(DIR, $LIB) || die "Cannot open \"$LIB\".\n";
@filelist1 = readdir(DIR);
closedir(DIR);
@filelist = sort(@filelist1);
foreach $filename (@filelist) {
	if ($filename !~ /^support\.(.*)\.pl$/) {next;}
	$lang = $1;
	$libname = "$LIB/$filename";
	open (FILE,$libname) || die "Cannot open \"$libname\".\n";
	$langname0 = <FILE>;
	close(FILE);
	if ($langname0 =~ /!(.*)!/) {
		$langname = $1;
		push (@languages, "$lang  ($langname)");
	} else {
		push (@languages, "$lang");
	}
}

if ($opt_s) {
	foreach $lang (@languages) {
		print "$lang\n";
	}
	exit(0);
}

# ----------- Select Language ------------
# ----------------------------------------
if (length($opt_l)) {
	if (-e "$LIB/support.$opt_l.pl") {
		$LANGUAGE=$opt_l;
	} else {
		die "Invalid language: $opt_l\n";
	}
} else {
	$l=-1;
	$l=0 if (@languages==1);
	while(($l<1 || $l>@languages) && @languages>1) {
		for($i=0; $i<@languages; $i++) {
			$j = $i + 1;
			print stderr "$j : $languages[$i]\n";
		}
		print STDERR "Input number > "; $l = <STDIN>;
	}
	$languages[$l-1] =~ /([^ \t]*)/;
	$LANGUAGE = $1;
}

# ----------- Load Language Support File ------------
# $LIB/support.$LANGUAGE.pl contains language-specific 
# functions.
# ---------------------------------------------------
if (open(FILE, "$LIB/support.$LANGUAGE.pl")) {
	@whole = <FILE>; close(FILE); $whole2 = join("",@whole);
	package Lang;
	eval($::whole2);
	if ($@) {
		die "ERROR in $::LIB/support.$::LANGUAGE.pl\n$@\n";
	}
	package main;
} else {
	warn "Warning: Cannot open: $LIB/support.$LANGUAGE.pl\n";
}

# load template file to avoid error by incomplate support file
if (open(FILE, "$LIB/support.language.pl.template")) {
	@whole = <FILE>; close(FILE); $whole2 = join("",@whole);
	package Ltmp;
	eval($::whole2);
	if ($@) {
		die "ERROR in $::LIB/support.language.pl.template\n$@\n";
	}
	package main;
} else {
	die "Cannot open: $LIB/support.language.pl.template\n";
}

# decide which to use
@subs = (isNC, initialize, sourceset2displayset, analcode, convcode);
foreach $sub (@subs) {
	if (defined &{"Lang::".$sub}) {
		${"Lang_".$sub}=\&{"Lang::".$sub};
	} else {
		${"Lang_".$sub}=\&{"Ltmp::".$sub};
		warn "Warning: $LIB/support.$LANGUAGE.pl: '$sub' does not exist.\n";
	}
}

if ($Lang::yes_upper eq "") {$Lang::yes_upper = $Ltmp::yes_upper;}
if ($Lang::yes_lower eq "") {$Lang::yes_lower = $Ltmp::yes_lower;}
if ($Lang::no_upper  eq "") {$Lang::no_upper  = $Ltmp::no_upper; }
if ($Lang::no_lower  eq "") {$Lang::no_lower  = $Ltmp::no_lower; }

# ----------- Load General File for dot.*.pl ------------
# $LIB/general.pl contains subroutines which can be used
# from dot.*.pl.
# -------------------------------------------------------
if (open(FILE, "$LIB/general.pl")) {
	@whole = <FILE>; close(FILE); $whole2 = join("",@whole);
	package Sub; 
	eval($::whole2);
	if ($@) {
		die "ERROR in $::LIB/general.pl\n$@\n";
	}
	package main;
} else {
	die "Cannot open: $LIB/general.pl\n";
}


# ---------- native character environment? ----------
# 'native character environment' means that non-ASCII 
# native characters such as Kanji in Japanese can be 
# displayed correctly.
# The result will be contained into $NC
# and $Sub::NC.
# ---------------------------------------------------
$o = "-l " . $LANGUAGE;
if ($opt_h) {$o .= " -h";}
if ($opt_v) {$o .= " -v";}
if ($opt_c) {
	$NC = 0;
} elsif ($opt_C) {
	$NC = 1;
} else {
	$NC = &$Lang_isNC($THIS, $o, $opt_N);
}
$Sub::NC = $NC;

# ---------- Other Initializations ------------
# ---------------------------------------------
END {
	eval {
		&printf_("\nPush [Enter] key to End.\n");
		$a = <STDIN>;
	}
}
if ($opt_h) {
	&printf_(
"Usage: set-language-env [options]\n".
"  -l language : Specify language (otherwise choose from menu)\n".
"  -h          : This help message\n".
"  -v          : 'verbose mode'\n".
"  -s          : Display list of supported languages and exit\n".
"  -r          : Remove all settings\n".
"  -N          : Never fork another set-language-env (for internal use)\n".
"  -c          : Don't use native character set (for internal use)\n".
"  -C          : Use native character set (for internal use)\n".
"  -E          : Setting for /etc/skel directory (root user only)\n"
	);
	exit(0);
}
&printf_("Now obtaining package list...\n");
$a = `dpkg --get-selections`;
@a = split('\n',$a);
@b = grep(/[ \t]install$/, @a);
foreach $c (@b) {$d=$c; $d =~ s/[ \t].*//o; push(@DPKG_LIST, $d);}
&$Lang_initialize();

# ---------- main loop ----------
# Read each '/usr/share/language-env/<language>.dot.*' file
# and process them.
# -------------------------------

@filelist = &readdir2($LANGUAGE);
foreach $filename (@filelist) {
	$dotname = $filename;
	$dotname =~ s+/dot\.+/\.+g;
	$dotname =~ s+^$LIB/$LANGUAGE+$HOME+;
	$scriptmode = $dotname =~ s+\.pl$++;

	print STDERR "\n------- $dotname --------\n";

	# read the template file
	($comment, $mes1, $mes2, $execute, $startpoint, $dotcontent) = 
		&readtemplate($filename);

	# display explanation message in the setting file
	package Sub;
	&disp($::mes1, $::mes2);
	package main;
	
	# ask whether to do setting
	print STDERR "\n"; &printf_("Do setting? ");
	$yn = &Sub::yesno("","");
	if ($yn == 0) {
		&printf_("Setting is not done.\n");
		next;
	}
	&printf_("Do setting...\n");

	# read the dotfile
	($out1, $out2) = &readdotfile($dotname, $comment, $startpoint);
	
	# execute the setting file if it is a perl script
	if ($scriptmode) {
		$dotcontent = &execscript($dotcontent, $TMP, $out1, $out2);
	}

	# write the setting to dot-files
	&addfile($dotname, $out1, $out2, $comment, $dotcontent);
	if ($execute ne 'x') {chmod(0644, $dotname);}
	if ($execute eq 'x') {chmod(0755, $dotname);}
}
unlink($TMP);
print STDERR "--------------------\n";
&printf_(
"   Setting is now done.  To activate these settings,\n".
"logout and login.\n".
"   Read each dotfile and confirm the modification.\n".
"If you don't like the setting, modify directly or\n".
"add overriding setting after 'language-env end' line.\n".
"   Read /usr/share/doc/language-env/README.* for detail.\n"
);

if (@RequiredPackageList > 0) {
	print STDERR "\n";
	&printf_("Install the following packages.\n");
	for ($a=0; $a<@RequiredPackageList; $a++){
		print STDERR "$RequiredPackageList[$a]";
		if ($a != @RequiredPackageList-1) {print STDERR ", ";}
	}
	print STDERR "\n";
}

if (open(FILE, "/etc/locale.gen")) {
	@localegen = <FILE>; close(FILE); 
	$localegen2 = "\n" . join("",@localegen);
} else {
	$localegen2 = "";
}

$numlocale = 0;
foreach $locale (split(" ", $Lang::need_locale)) {
	($locale1, $locale2) = ($locale =~ /\s*([^\s(]*)\s*\(\s*([^)]*)/);
	if ($locale1 eq "") {$locale1 = $locale;}
	$locale2 =~ tr/!/ /;
	$locale3 = $locale2; $locale3 =~ s/ /\\s+/;
	if ($localegen2 !~ /\n$locale3/) {
		if ($numlocale == 0) {
			print STDERR "\n";
			&printf_("Install the following locales.\n");
			&printf_("(Edit /etc/locale.gen and invoke locale-gen)\n");
		}
		if ($locale2 eq "") {
			print STDERR "$locale1\n";
		} else {
			print STDERR "$locale1 (\"$locale2\" in /etc/locale.gen)\n";
		}
		$numlocale ++;
	}
}

# ---------- subroutine(s) ----------
# readdir2(language);
# read all setting files for the language.
sub readdir2($) {
	return readdir3("$LIB/$_[0]");
}

sub readdir3($) {
	my ($dir, $name, @list, @list1, @list2);
	$dir = $_[0];
	@list = (); @list1 = (); @list2 = ();
	opendir(DIR, $dir) || die "Cannot open \"$dir\".\n";
	while($name = readdir(DIR)) {
		if ($name eq "." || $name eq "..") {next;}
		elsif (-d "$dir/$name") {push(@list2, "$dir/$name");}
		else {push(@list1, "$dir/$name");}
	}
	closedir(DIR);
	push(@list, sort(@list1));
	@list2 = sort(@list2);
	foreach $name (@list2) {
		push(@list, readdir3("$name"));
	}
	return @list;
}

# mkdir2(filename);
# recursive make directory
sub mkdir2($) {
	my ($filename, $dir, $file);
	$filename = $_[0];
	$i=1;
	while(1){
		$filename =~ m"((/[^/]+){$i})(.*)";
		$dir = $1; $file = $3; $i++;
		if ($file !~ m+/+) {return 1;}
		if (-d $dir) {next;}
		if (-e $dir) {return 1;}
		mkdir ($dir, 0755) || return 1;
	}
}


# readtemplate(template file name);
#
sub readtemplate($) {
	my ($filename, $comment, $execute, $startpoint, $whole2);
	my ($first, $mes1, $l, $mes2, @whole);
	$filename = $_[0];
	
	open(TFILE,$filename) || die "Cannot open \"$filename\".\n";
	$first = <TFILE>;
	$mes1 = "";
	while ($l = <TFILE>) {
		if ($l eq "END\n") {last;}
		$mes1 .= $l;
	}
	$mes2 = "";
	while ($l = <TFILE>) {
		if ($l eq "END\n") {last;}
		$mes2 .= $l;
	}
	@whole = <TFILE>; close(TFILE);
	$comment = substr($first, 0, 1);
	$execute = substr($first, 1, 1);
	$startpoint = (substr($first, 2, 1) eq 's');
	$whole2 = join("", @whole);
	return ($comment, $mes1, $mes2, $execute, $startpoint, $whole2);
}


# readdotfile(name of dotfile, 
#            character a comment line begin with,
#            whether adding part is added at the first or last);
#
sub readdotfile ($$$) {
	my ($FILE, $DELIM10, $DELIM20, $DELIM1, $DELIM2, $STARTPOINT);
	my (@file, $out1, $out2, $mode);

	$FILE = $_[0];
	$DELIM10 = "$_[1]$delimstart0";
	$DELIM20 = "$_[1]$delimend0";
	$DELIM1 = "$_[1]$delimstart";
	$DELIM2 = "$_[1]$delimend";
	$STARTPOINT = $_[2];

	# read the file
	undef @file;
	if (! -e "$FILE") {
	} elsif (!open(FP, "$FILE")) {
		&printf_("Cannot read \"%s\".\n",$FILE);
		return ("", "");
	}
	@file=<FP>;
	close(FP);

	# analysis of the read content
	$out1 = ""; $out2 = ""; $mode = 0;
	foreach (@file) {
		if ($mode==0 && ($_ eq "$DELIM1\n" || $_ eq "$DELIM10\n"))
			{$mode=1;}
		if ($mode==0) {$out1 .= $_;}
		if ($mode==2) {$out2 .= $_;}
		if ($mode==1 && ($_ eq "$DELIM2\n" || $_ eq "$DELIM20\n"))
			{$mode=2;}
	}
	if ($STARTPOINT && $mode==0) {
		$out2 = $out1;
		$out1 = "";
	}
	return ($out1, $out2);
}

# execscript (contents of script,
#             temp file name,
#             contents of dotfile(1),
#             contents of dotfile(2));
sub execscript ($$$$) {
	my($CONTENTS, $TMPFILE, $OUT1, $OUT2, @whole1, $whole2);
	$CONTENTS = $_[0];
	$TMPFILE = $_[1];
	$OUT1 = $_[2];
	$OUT2 = $_[3];

	if (!open(TMP, "+>$TMPFILE")) {
		&printf_("Cannot open \"%s\".\n",$TMPFILE);
		exit(1);
	}
	open(SAVE, ">&STDOUT");
	open(STDOUT, ">&TMP");
	$Sub::contents = $CONTENTS;
	$Sub::DOTFILECONTENTS1 = $OUT1;
	$Sub::DOTFILECONTENTS2 = $OUT2;
	package Sub;
	eval($contents);
	if ($@) {die "Internal error in $::filename !!\n$@";}
	package main;
	open(STDOUT, ">&SAVE");
	seek(TMP, 0, 0);
	@whole1 = <TMP>; close(TMP);
	unlink($TMPFILE);
	$whole2 = join("", @whole1);
	return $whole2;
}

# addfile(name of existing dotfile,
#            content of existing dotfile(1),
#            content of existing dotfile(2),
#            character a comment line begin with, 
#            adding content);
#
sub addfile ($$$$$) {
	my ($FILE, $OUT1, $OUT2, $DELIM1, $DELIM2, $ADD, $out, $codeset, $c);
	$FILE = $_[0];
	$OUT1 = $_[1];
	$OUT2 = $_[2];
	$DELIM1 = "$_[3]$delimstart";
	$DELIM2 = "$_[3]$delimend";
	$ADD = $_[4];

	# rename (make backup)
	if (-e "$FILE") {
		rename("$FILE", "$FILE$BACKUPPOSTFIX");
	} else {
		&printf_("Making a new file \"%s\"...\n", $FILE);
	}

	# open for write and lock
	if (open(FP,">$FILE")) {
	} elsif (mkdir2($FILE) && open(FP,">$FILE")) {
	} else {
		&printf_("Cannot write to \"%s\".\n",$FILE);
		return;
	}
	if (!flock(FP, 2)) {
		&printf_("Cannot lock \"%s\".\n",$FILE);
		close(FP);
		return;
	}

	# check codeset
	$codeset = &$Lang_analcode($OUT1 . $OUT2);
	if ($opt_v) {
		$c = &$Lang_analcode($ADD);
		print STDERR "Template is written in codeset \"$c\".\n";
		print STDERR "$FILE is written in codeset \"$codeset\".\n";
	}
	$ADD2 = &$Lang_convcode($ADD, $codeset);

	# output
	$out = "$OUT1$DELIM1\n$ADD2$DELIM2\n$OUT2";
	print FP $out;
	if (!close(FP)) {
		&printf_("Cannot close \"%s\".\n",$FILE);
		exit(1);
	}
}

# Remove lines surrounded by '---- language-env' lines
# from all dot-files.

sub remove_setting () {
	@filelist = glob("$HOME/.*");
	foreach $additional (
		"$HOME/.elm/elmrc",
		"$HOME/bin/x-terminal-emulator"
	) {push(@filelist, $additional) if (-e $additional);}
#	opendir(DIR, $HOME) || die "Cannot open \"$HOME\".\n";
#	@filelist = readdir(DIR);
#	closedir(DIR);
	foreach $filename (@filelist) {
		if (-d $filename) {next;}
#		if ($filename !~ /^\./) {next;}
#		if ($filename =~ /~$/) {next;}
		if (index($filename,$BACKUPPOSTFIX) > 0) {next;}
#		if ($filename eq "." || $filename eq "..") {next;}
		if (! -f "$filename") {next;}

		if (!open (FP, "+<$filename")) {
			print STDERR "Cannot read \"$filename\".\n";
			next;
		}
		if (flock(FP, 2)) {
			@file=<FP>;
		} else {
			print STDERR "Cannot lock \"$filename\".\n";
			close(FP); next;
		}
		$file2 = join("", @file);
		if (index($file2, $delimstart) == -1 &&
		    index($file2, $delimstart0) == -1) {close(FP); next;}
		if (index($file2, $delimend) == -1 &&
		    index($file2, $delimend0) == -1) {close(FP); next;}

		$out1 = ""; $out2 = ""; $mode = 0;
		foreach (@file) {
			$a = substr($_, 1); chomp($a);
			if ($mode==0 && ($a eq $delimstart || 
			    $a eq $delimstart0)) {$mode=1;}
			if ($mode==0) {$out1 .= $_;}
			if ($mode==2) {$out2 .= $_;}
			if ($mode==1 && ($a eq $delimend ||
			    $a eq $delimend0)) {$mode=2;}
		}
		$out = $out1 . $out2;
		seek(FP, 0, 0);
		print FP $out;
		truncate(FP, length($out));
		if (!close(FP)) {
			print STDERR "Cannot close \"$filename\".\n";
			exit(1);
		}
		if (length($out) == 0) {
			unlink("$filename");
		}
	}
}

# printf_ is a subroutine to display messages in desired
# language according to Native Character Environment.
# The name 'printf_' is come from 'printf' and '_' which
# is usually used as a macro for 'gettext()'.
#
# The message strings in various languages are prepared
# in the language support files
# (/usr/share/language-env/support.<language>.pl) as a hash
# 'messages'.  The hash variable has to have two sets of
# translated messages, one is written in ASCII character
# set and the other in native character set.  See comments
# in support.language.pl.template and README.i18n for
# detail.
#
# printf_(format, [parameter,...]);

sub printf_ ($@) {
	my ($a, $a1, $a2, $b);
	$a = $Lang::messages{$_[0]};
	if ($a eq "") {$a = $Ltmp::messages{$_[0]};}
	if ($a =~ /([^\000]*)\000([^\000]*)/) {
		if ($Sub::NC) {$b = $2;} else {$b = $1;}
		if ($b eq "") {$b = $1;}
	} else {
		$b = $a;
	}
	if ($b eq "") {$b = $_[0];}
	shift @_;
	print STDERR &$Lang_sourceset2displayset(sprintf($b,@_));
}

# Convert canonical locale name into directory name in /usr/lib/locale.

sub canonical2directory ($) {
	my ($locale) = $_[0];
	my ($a, $b, $c) = ($locale =~ /([^\.@]+)(\.[^@]+)?(@.*)?/ );
	if ($b eq "") {return $locale;}
	$b =~ s/_//g;
	$b =~ s/-//g;
	$b =~ tr/A-Z/a-z/;
	return $a.$b.$c;
}