#!/bin/perl
#
#  miopatch.pl - patch for madoka 4.x
#
#  Copyright(c)1999- cookie / Project MIO
#   Project MIO is under madoka project.
#

require 5.003;
require './kanji.mpi';

$mio_label = 'miopatch';
$mio_version = '1.0';
$mdk_label = 'madoka';
$mdk_version = '4.x';
$debug = 0;

&mes("$mio_label $mio_version for $mdk_label $mdk_version" .
     " (c)1999 Project MIO");
&mes();
&main;
exit;

sub main {
  local($key, $mes, $kd, $kf, $kfl, $kn, $file, $f, $d1, $d2, $d3,
	$l, $cl, $sp);
  local(%line, %file, @l);
  &init;
  @l = &read_conf;
  foreach (@l) {
    s/\r*\n$//;
    next if /^\s*$/ || /^\#/;
    ($key, $mes) = split(/=/, $_, 2);
    ($kd, $kf, $kn) = split(/_/, $key, 3);
    $kfl = lc($kf);
    $mes{$key} = $mes;

    if (/^\s*\[(.+)\]\s*$/) {
      &mes("Configuration type: $1");
      next;
    } elsif ($kd eq 'DIR') {
      $mes =~ s/\/$//;
      if (-f "$mes/madoka.pl") {
	$DIR = $mes;
	&mes("Target Directory: $DIR");
	next;
      } elsif (-f "./madoka.pl") {
	$DIR = ".";
	&mes("Target Directory: $DIR");
	next;
      } else {
	&mes("ERROR: incorrect directory: $mes");
	exit;
      }
    } elsif ($kd eq 'MADOKA' && $DIR) {
      $file = "$DIR/madoka.pl";
    } elsif ($kd eq 'SERVER' && $DIR) {
      $file = "$DIR/plugin/server/$kfl.mpi";
      unless (-f $file) {
	&mes("WARNING: no such file: $file");
	&mes("WARNING: Ignored.");
	next;
      }
    } elsif ($kd eq 'CLIENT' && $DIR) {
      $file = "$DIR/plugin/client/$kfl.mpi";
      unless (-f $file) {
	&mes("WARNING: no such file: $file");
	&mes("WARNING: Ignored.");
	next;
      }
    } elsif ($kd eq 'CTCP' && $DIR) {
      $file = "$DIR/plugin/ctcp/$kfl.mpi";
      unless (-f $file) {
	&mes("WARNING: no such file: $file");
	&mes("WARNING: Ignored.");
	next;
      }
    } elsif ($kd eq 'RC' && $DIR) {
      $file = "$DIR/plugin/rc/$kfl.mpi";
      unless (-f $file) {
	&mes("WARNING: no such file: $file");
	&mes("WARNING: Ignored.");
	next;
      }
    } else {
      unless ($DIR) {
	&mes("ERROR: no DIR exist first in $mioconf");
	exit;
      } else {
	&mes("WARNING: unknown KEY: $key");
	next;
      }
    }
    unless ($lines{$key}) {
      &mes("WARNING: undefined key: $key");
      &mes("WARNING: Ignored.");
      next;
    }
    &list_add($line{$kd}, "${kf}_$kn");
    &list_add($file{$kd}, $file);
  }

  # patch
  foreach $l (keys(%line)) {
    next unless $l;

    foreach $f (split(/$;/, $file{$l})) {
      next unless $f;
      $miotmp = "$f.tmp";
      unless (open(IN, $f)) {
	&mes("ERROR: cannot open file: $f");
	next;
      }
      @i = <IN>;
      close(IN);
      foreach (split(/$;/, $line{$l})) {
	next unless $_;
	s/_$//;
	($d) = split(/_/, lc($_));
	next unless ($l eq 'MADOKA' && $f eq "$DIR/madoka.pl") ||
	    $f =~ /\/$d\./;
	
	($sp, $cl, $m, $d1) = ($i[$lines{"${l}_$_"}-1] =~
			  /^(\s*)\&send\(\'(c.+)\',\s*\"(.+)\\n\"\)(.*)\;\s*$/);
	($d2, $com, $d3, $m) =
	    ($m =~ /^(:[^ ]+ *)?([^ ]+( [^: ]+)*) *:(.*)$/);

	&mes("[d] $d2 / $com / $d3 / $m :") if $debug;
	&kanji_euc(*mes{"${l}_$_"});

	$i[$lines{"${l}_$_"}-1] = "$sp\&send(\'$cl\', \"$d2$com :" .
	    $mes{"${l}_$_"} . "\\n\")$d1;\n";
      }
      unless (open(OUT, ">$miotmp")) {
	&mes("ERROR: cannot open file: $miotmp (for $f)");
	next;
      }
      print OUT @i;
      close(OUT);
      unless (rename($miotmp, $f)) {
	&mes("ERROR: cannot rename $miotmp to $f");
      }
#      &mes("Rename: $miotmp to $f");
    }
  }
  &mes("Patch done.");
}
sub init {
  $mioconf = $ARGV[0];
  require './miolines.conf';
}
sub read_conf {
  local(@l) = ();
  if (defined($mioconf)) {
    unless (open(CONF, $mioconf)) {
      &mes("ERROR: cannot open configuration file: $mioconf");
      exit;
    }
    @l = <CONF>;
    close(CONF);
  } else {
    @l = <STDIN>;
  }
  return @l;
}
sub mes {
  local($mes) = @_;
  $mes =~ s/\r*\n$//;
  print STDOUT "$mes\n";
}
sub list_init {
  $_[0] = "$;";
}
sub list_add {
  &list_init($_[0]) unless $_[0];
  unless (&list_exist(@_)) {
    $_[0] .= "$_[1]$;";
    return 1;
  }
  return 0;
}
sub list_exist {
  local($d, @pr) = @_;
  local($f, $l) = (0, '');
  foreach (@pr) {
    next unless $_;
    $l = $_;
    $l =~ s/(\W)/\\$1/g;
    if ($_[0] =~ /$;($l)$;/i) {
      substr($_[0], index($_[0], "$;$1$;"), length("$;$1$;")) = "$;";
      $_[0] .= "$_$;";
      $f = 1;
    }
  }
  return $f;
}