package MCoreTools;
require Exporter;

use strict;
use vars qw(
  @ISA @EXPORT
  %ModuleHooks
);

# FIXME: the export list really ought to be kept as simple as possible so as to
# avoid namespace conflicts with other packages AND object methods
#
# foo_PERMS: move into MFile
# rfoo: move into MFile
#
# sx2xml, xml2sx: keep
# xml2sx_file: move into MFile

@ISA = qw(Exporter);
@EXPORT = qw(
  IS_MACOS

  DATA_PERMS DIR_PERMS
  rfile rdir rmkpath rmkpathto rexists

  mudlog mudlog_indent mudlog_outdent
  carp cluck croak confess

  ObjectByID ObjectByName

  call_hooks call_ordered_hooks

  SX_ELEM SX_ATTR SX_CONT
  sx2xml xml2sx xml2sx_file
);

use File::Path ();
use File::Spec ();
use Cwd ();
use Carp; # can't specify list because Carp might not define cluck() depending on version
use IO::Seekable qw(SEEK_SET);

### Misc constants ##########################################################################################

# this constant refers to _classic_ Mac OS (1-9), not Mac OS X/Darwin
use constant IS_MACOS => $^O eq 'MacOS';

use constant DATA_PERMS => 0660;
use constant DIR_PERMS => DATA_PERMS | 0110;

### Logging ###################################################################

{
  use vars qw($log_indent @log_queue $log_event);
  use vars qw($logs_opened %logs %log_paths $log_last_message $log_repeat_count $log_seq_start $log_seq_end);
  use IO::File;
  my $log_el = "\cJ";
  my $repeat_combine_start = 10;
  my $mainpid = $$;
  $log_indent = 0 unless defined $log_indent;
  $log_last_message ||= '';
  $log_repeat_count ||= 0;

  # FIXME: log files ought to be defined in config file
  %logs = map {$_, undef} qw(
    mudlog user_reports priv_cmds errors webserver
  ) unless keys %logs;

  sub mudlog ($);
  sub mudlog ($) {
    # DO NOT change the prototype; some code depends on this subroutine
    # being parsed as a unary operator (e.g. or mudlog "foo", return;)
    my ($str) = @_;

    # in case we're called from a __WARN__ hook or such
    local $@;

    my $now = time();

    if ($str =~ /^  -- .+? times, /) {
      # repeat notify, ignore
      
    } elsif ($str eq $log_last_message) {
      # message repeated
      $log_repeat_count++;
      $log_seq_end = $now;
      return 1 if $log_repeat_count >= $repeat_combine_start;
      
    } else {
      # unique message
      if ($log_repeat_count >= $repeat_combine_start) {
        mudlog("  -- $log_repeat_count times, last at "
               . mudlog_format_time($log_seq_end)
               . ", avg interval "
               . ($log_seq_end - $log_seq_start) / ($log_repeat_count - 1)
               . " secs"
              );
      }
      $log_last_message = $str;
      $log_repeat_count = 1;
      $log_seq_start = $log_seq_end = $now;
    }

    my $fmark = ($$ != $mainpid ? " [pid: $$]" : '');

    my $prefix = sprintf "%s:%s%s ", mudlog_format_time($now), $fmark, (' ' x $log_indent);
    my $contin = ' ' x (21 + $log_indent);

    my @lines = map "$_\n", split /\n/, $str;
    my $msg = $prefix . shift(@lines);
    while (@lines) {
      $msg .= $contin . shift(@lines);
    }
    print STDOUT $msg;
    eval {MScheduler::mon_set($str)};

    return 1 if $fmark; # don't touch log files or IO if we're forked
    
    if ($logs_opened) {   
      $msg =~ s/\n/$log_el/g;
      print {$logs{'mudlog'}}     $msg;
      print {$logs{user_reports}} $msg if $str =~ /(\w+ REPORT|KEYWORD):/;
      print {$logs{priv_cmds}}    $msg if $str =~ /\(PC\)/;
      print {$logs{errors}}       $msg if $str =~ /(ERROR|WARNING:)/;
      print {$logs{webserver}}    $msg if $str =~ /Web:/;
    }

    if (eval {MScheduler->running}) {
      #print STDOUT "DEBUG: putting log message on queue (@log_queue)\n";
      push @log_queue, $str;
      #print STDOUT "DEBUG: put log message on queue (@log_queue)\n";
      if (!$log_event) {
        #print STDOUT "DEBUG: scheduling log print event\n";
        ($log_event = MEvent::Message->new(
          target => 'MCoreTools',
          method => 'mudlog_write',
        ))->schedule;
      }
    }
    return 1;
  }

  sub mudlog_format_time ($) {
    my ($sec,$min,$hour,$mday,$mon,$year) = localtime($_[0]);
    return sprintf "%04d-%02d-%02d %2d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
  }

  sub mudlog_write {
    $log_event = undef;
    #print STDOUT "mudlog_write\n";
    for my $str (@log_queue) {
      #print STDOUT "mudlog_write: $str\n";
      call_hooks('mudlog', $str);
    }
    @log_queue = ();

    foreach (keys %logs) {
      my $path = $log_paths{$_};
      my $overflow = (-s $path) - $::Config{log_maxsize};
      next unless $overflow > 0;

      print STDOUT "Trimming log file '$_'\n";
      close $logs{$_};

      my $tmph = IO::File->new($path, '<', DATA_PERMS) or die "Log file $_ couldn't be reopened: $!";
      $tmph->seek($overflow + $::Config{log_maxsize} / 10, SEEK_SET);
      my $data = do {local $/; <$tmph>};
      $tmph->close;

      $data =~ s/$log_el{3,}/$log_el$log_el/o;

      $logs{$_} = IO::File->new($path, '>', DATA_PERMS) or die "Log file $_ couldn't be reopened: $!";
      $logs{$_}->print($data);
    }
    1;
  }

  sub open_log {
    my ($class) = @_;
    
    my $logd = $::Config{log_path} or croak "No log_path specified in config file!";
    rmkpath($logd);

    foreach (keys %logs) {
      $log_paths{$_} = rfile("$logd/$_");
      $logs{$_} = IO::File->new($log_paths{$_}, '>>', DATA_PERMS) or die $!;
      $logs{$_}->autoflush(1);
      $logs{$_}->print($log_el);
    }
    
    $logs_opened = 1;
    mudlog "--- Log starts ---";
  }
  
  sub mudlog_indent  () {$log_indent += 2}
  sub mudlog_outdent () {$log_indent -= 2}
}

### Signals and warning hook ##################################################

sub sig ($$) {
  my ($sig, $val) = @_;
  $SIG{$sig} = $val if exists $SIG{$sig};
}

sub install_signal_handlers {
  # alright, what's the difference between SIGQUIT and SIGTERM? i
  # think the answer is SIGTERM means "system shutting down", whereas
  # SIGQUIT is a user request to "terminate now", and SIGINT just means
  # "stop what you're doing".
  #
  # is it legal to die() inside a signal handler?
  #
  # Ilya says return; at the end of a signal handler will reduce
  # the amount of things done in it by preventing a return value

  my $reaper;
  $reaper = sub { wait; $SIG{CHLD} = $reaper; return};

  $SIG{__WARN__} = sub {mudlog "WARNING: $_[0]" unless $_[0] =~ /Ambiguous use of .* resolved to .*\./};
  sig PIPE => 'IGNORE';
  sig CHLD => $reaper;
  sig INT  => sub {$::Quit = 'SIGINT'; return};
  sig QUIT => sub {$::Quit = 'SIGQUIT'; return};
  sig TERM => sub {$::Quit = 'SIGTERM'; return};
  sig USR1 => sub {$::Quit = 'restart'; return};
  sig HUP  => 'IGNORE';
}

### Pathname functions ########################################################

{
  (my $RootDir) = Cwd::fastcwd() =~ /^(.*)$/;

  sub rfile ($) {return File::Spec->catfile($RootDir, grep $_, split /\//, $_[0])}
  sub rdir  ($) {return File::Spec->catdir( $RootDir, grep $_, split /\//, $_[0])}
  sub rmkpath ($) {File::Path::mkpath(rdir($_[0]), 0, DIR_PERMS)}
  sub rmkpathto ($) {my $t = $_[0]; $t =~ s#[^/]*$##; rmkpath($t);}
  sub rexists ($) {-e rfile($_[0])}
}

### Utility functions #########################################################

sub ObjectByID     ($) {local $Carp::CarpLevel = $Carp::CarpLevel + 1; MObjectDB->get($_[0])}
sub ObjectByName   ($) {local $Carp::CarpLevel = $Carp::CarpLevel + 1; MObjectDB->get_name($_[0])}
#sub ObjectByString ($) {local $Carp::CarpLevel = $Carp::CarpLevel + 1; ...}

BEGIN {eval 'sub cluck {warn Carp::longmess @_}' unless defined &cluck}

### Hooks #####################################################################

sub init_hooks {
  require MDefList; initialize MDefList;
  MDefList->new(
    source => 'CORE',
    name => 'Hooks',
    type => 'CODE',
    multiple => 1,
    mirror => \%ModuleHooks,
  );
}

sub call_hooks {
  shift if $_[0] eq __PACKAGE__; # enable calling as class method
  my $hookname = shift;
  my @ret;
  foreach (values %{$ModuleHooks{$hookname}}) {
    push @ret, eval {$_->(@_)};
    $@ and mudlog "ERROR: death while running '$hookname' hooks:\n$@";
  }
  @ret;
}

sub call_ordered_hooks {
  shift if $_[0] eq __PACKAGE__; # enable calling as class method
  my $hookname = shift;
  my @ret;
  my $hooks = $ModuleHooks{$hookname};
  foreach my $key (sort keys %$hooks) {
    my $h = $hooks->{$key};
    push @ret, eval {$h->(@_)};
    $@ and mudlog "ERROR: death while running '$hookname' hooks:\n$@";
  }
  @ret;
}

### XML/SX: Constants, conversion and processing ##############################

use constant SX_ELEM => 0;
use constant SX_ATTR => 1;
use constant SX_CONT => 2;

sub sx2xml {
  @_ > 1 and return join '', map sx2xml($_), @_;
  my ($thing) = @_;

  if (ref $thing ne 'ARRAY') {
    return "<!--undef-->" if not defined $thing;
    $thing = "$thing" if ref $thing;

    $thing =~ s/&/&amp;/g;
    $thing =~ s/</&lt;/g;
    $thing =~ s/>/&gt;/g;
    return $thing;
  
  } else {
    my $attrs = $thing->[SX_ATTR] or die "sx2xml: missing attribute hash";
    return "<$thing->[SX_ELEM]"
         . join('', map {
             my $v = $attrs->{$_};
             $v =~ s/&/&amp;/g;
             $v =~ s/'/&apos;/g;
             " $_='$v'";
           } keys %$attrs)
         . ($#$thing >= SX_CONT
             ? '>' . join('', map sx2xml($_), @{$thing}[SX_CONT..$#$thing])
                   . "</$thing->[SX_ELEM]>"
             : '/>'
           )
         ;
  }
}

eval "# line ".(__LINE__+1).' "'.__FILE__.qq{"\n}.<<'EOC'; die $@ if $@ and $@ !~ m#XML/Parser.pm#;
  # xml2sx processing.
  # NOTE: This code is NOT thread-safe. It uses lexicals outside of
  # the scope of the xml2sx subroutine. If this needs to be made thread-
  # safe, just move the creation of the XML::Parser object inside 
  # xml2sx.
  
  use XML::Parser;

  my ($sxout, @estack, $epreserve);

  my $p = XML::Parser->new(
    Handlers => {
      Init => sub {
        my ($exp) = @_;
        $sxout = undef;
        $epreserve = 0;
      },
      Final => sub {
        my ($exp) = @_;
        @estack = ();
      },
      Start => sub {
        my ($exp, $elem, %attr) = @_;
        my $sx = [$elem, {%attr}];
        if (@estack) {
          push @{$estack[-1]}, $sx;
        } else {
          # check disabled because expat checks this for us
          # !$sxout or die "xpe[second root element encountered]"; 
          $sxout = $sx;
        }
        push @estack, $sx;
        $epreserve++ if ($sx->[SX_ATTR]{'xml:space'} || '') eq 'preserve';
      },
      End => sub {
        my ($exp, $elem) = @_;
        my $sx = pop @estack;
        # check disabled because expat checks this for us
        # $sx->[0] eq $elem or die "xpe[end tag '$elem' doesn't match start tag '$sx->[0]']";
        
        # combine adjacent text nodes
        for (my $i = SX_CONT; $i < $#$sx; $i++) {
          if (!ref $sx->[$i] and !ref $sx->[$i+1]) {
            splice @$sx, $i, 2, join('', @$sx[$i..$i+1]);
            $i--;
          }
        }
        if (!$epreserve) {
          for (@$sx) {
            next if ref;
            s/[\cM\cJ\cI ]+/ /g;
          }
          if ($#$sx >= SX_CONT) {
            $sx->[SX_CONT] =~ s/^ +// unless ref $sx->[SX_CONT];
            $sx->[-1]      =~ s/ +$// unless ref $sx->[-1];
          }
        }
        $epreserve-- if ($sx->[SX_ATTR]{'xml:space'} || '') eq 'preserve';
      },
      Char => sub {
        my ($exp, $text) = @_;
        # check disabled because expat checks this for us
        # @estack or die "xpe[text encountered ouside of any element]";
        my $node = $estack[-1];
        push @$node, $text;
      },
    },
    ProtocolEncoding => 'US-ASCII',
  );
  
  sub xml2sx {
    $p->parse($_[0]);
    
    # save a little (or a lot) of memory
    my $sx = $sxout;
    $sxout = undef;
    return $sx;
  }
  
  sub xml2sx_file {
    $p->parsefile(rfile($_[0]));
    my $sx = $sxout;
    $sxout = undef;
    return $sx;
  }
EOC

1;
