package MCoreTools;
require Exporter;

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

@ISA = qw(Exporter);
@EXPORT = qw(
  DATA_PERMS DIR_PERMS
  %GENDER_NOM %GENDER_OBJ %GENDER_POSS

  mudlog
  carp cluck croak confess complain
  rfile rdir rmkpath

  dice min max grepfirst
  parse_time format_time
  try catch
    
  Hooks call_hooks
);

use File::Spec ();
use Cwd ();
use Carp;
use IO::Seekable qw(SEEK_SET);

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

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

%GENDER_NOM  = qw(neuter it  male he  female she plural they );
%GENDER_OBJ  = qw(neuter it  male him female her plural them );
%GENDER_POSS = qw(neuter its male his female her plural their);

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

{
  use vars qw($reenter);
  use vars qw($logs_opened %logs %log_paths);
  use IO::File;
  my $log_el = "\cJ";
  $reenter = 0;

  %logs = map {$_, undef} qw(mudlog user_reports priv_cmds edits errors);

  sub mudlog ($) {
    my ($str) = @_;

    local $reenter = $reenter + 1;
    my @str = split /\n/, $str;
    (my $single = $str) =~ s#\s*\n\s*(\S)# / $1#g;

    my $msg = _logdate() . ': ' . shift(@str) . "\n";
    while (@str) {
      $msg .= (' ' x 20) . shift(@str) . "\n";
    }
    print STDOUT $msg;

    if (MObjectDB->is_open) {
      foreach (all MConnection) {
        my $obj = ($_ or next)->object or next;
        $obj->get_val('priv_watcher') or next; # FIXME: reference to privilege field in engine
        $_->send("&:f" . ($str =~ /^(ERROR|Warning:)/ ? 'r' : 'g') . "[[ $single ]]&:n");
      }
    }

    return unless $logs_opened;
    
    $msg =~ s/\n/$log_el/g;
    print {$logs{mudlog}}       $msg if $str !~ /^(main loop speed: |Auto zone reset: )/;
    print {$logs{user_reports}} $msg if $str =~ /^(\w+ REPORT|KEYWORD):/;
    print {$logs{priv_cmds}}    $msg if $str =~ /^\(PC\)/;
    print {$logs{edits}}        $msg if $str =~ /^EDIT/;
    print {$logs{errors}}       $msg if $str =~ /^(ERROR|Warning:)/;
    
    return unless MScheduler->running;
    
    foreach (keys %logs) {
      my $path = $log_paths{$_};
      my $overflow = (-s $path) - $::Config{log_maxsize};
      return 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 _logdate {
    my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
    return sprintf "%04d-%02d-%02d %2d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
  }

  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 ---";
  }
}

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

$SIG{__WARN__} = sub {
  my ($wt) = @_;
  #return if $wt =~ /Use of uninitialized value.* during global destruction/;
  mudlog "Warning: $_[0]";
};
$SIG{PIPE} = 'IGNORE' if exists $SIG{PIPE};

### 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)}
}

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

sub complain {
  carp "complain() is deprecated. use cluck() instead.";
  goto &cluck;
}
BEGIN {eval 'sub cluck {warn Carp::longmess @_}' unless defined &cluck}

sub dice ($;$$); # declaration to avoid "too early to check prototype" due to recursion
sub dice ($;$$) {
  my ($num, $sides, $total) = @_;
  # number of dice, sides of dice, fixed value to add
  
  if (not defined($sides)) { # single string arg, XdY+Z
    my ($n, $s, $p) = $num =~ /^\s*(\d+)\s*d\s*(\d+)(?:\s*\+(\d+))?\s*$/;
    $n or return undef;
    return dice($n, $s, $p);
  }
  
  # += doesn't care whether its argument is undef.
  while ($num-- > 0) {
    $total += int(rand($sides)) + 1;
  }
  $total;
}    

#FIXME: use variable time units
use constant T_MINUTE => 60;
use constant T_HOUR => T_MINUTE * 60;
use constant T_DAY => T_HOUR * 24;

sub parse_time ($) {
  my ($str) = @_;
  #print "parse_time($str)\n";
  my $time = 0;
  my $val;
  while ($str =~ s/(-?\d+(?:\.\d+)?)([dhms]?)//) {
    ($val, my $unit) = ($1, $2);
    last unless $val;
    next if not $unit or $unit eq 's';
    $val *= 60; # minutes
    next if $unit eq 'm';
    $val *= 60; # hours
    next if $unit eq 'h';
    $val *= 24; # days
    next if $unit eq 'd';
  } continue {
    $time += $val;
  }
  return $time;
}

sub format_time ($) {
  my ($tyme) = @_;
  my $days =    int($tyme / T_DAY   ); $tyme -= $days    * T_DAY;
  my $hours =   int($tyme / T_HOUR  ); $tyme -= $hours   * T_HOUR;
  my $minutes = int($tyme / T_MINUTE); $tyme -= $minutes * T_MINUTE;
  my $out = ( 
     ($days ? "${days}d" : '')
    .($hours ? "${hours}h" : '')
    .($minutes ? "${minutes}m" : '')
    .($tyme ? sprintf("%.1fs", $tyme) : '')
  );
  return $out ? $out : '0';
}

sub try (&@) {
  my($try, $catch) = @_;
  my $result;
  eval { $result = &$try };
  if ($@) {
    local $_ = $@;
    $result = &$catch;
  }
  return $result;
}
sub catch (&) { $_[0] }

sub grepfirst (&@) {
  # Just like grep() in scalar context, except returns upon the first match.
  # Tests with Benchmark have shown that for a simple sub {$_ eq $key}, it is slower
  # than grep(). Use with caution.
  my $sub = shift;
  foreach (@_) {
    return 1 if $sub->(); # implicit local $_ = <element>
  }
  return 0;
}

sub max {
  my $now = shift;
  foreach (@_) {
    $now = $_ if $_ > $now;
  }
  $now;
}

sub min {
  my $now = shift;
  foreach (@_) {
    $now = $_ if $_ < $now;
  }
  $now;
}

### Module hooks ##########################################################################################

sub Hooks {
  my (%hooks) = @_;
  $MModules::ModuleEvalContext or croak 'MCoreTools::Hooks called outside of module eval context';
  if ($MModules::ModuleEvalContext eq 'unload') {
    foreach (keys %hooks) {delete $ModuleHooks{$_}{$MModules::ModuleEvalName};}
  } else {
    foreach (keys %hooks) {
      $ModuleHooks{$_}{$MModules::ModuleEvalName} = $hooks{$_};
    }
  }
}

sub call_hooks {
  my $hookname = shift;
  my @ret;
  foreach (values %{$ModuleHooks{$hookname}}) {
    push @ret, eval {$_->(@_)};
    $@ and mudlog "ERROR: death while running '$hookname' hooks:\n$@";
  }
  @ret;
}

1;
