package MCoreTools;
require Exporter;

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

@ISA = qw(Exporter);
@EXPORT = qw(
  DATA_PERMS
  DIR_PERMS
  ROOM_PROTO
  TICK_INTERVAL

  %GENDER_NOM
  %GENDER_OBJ
  %GENDER_POSS

  mudlog
  parse_file_ref
  dice
  relfpath reldpath
  parse_time
  format_time
  try catch
  grepfirst
  
  carp  cluck
  croak confess 
  complain
);

use File::Spec;
use Cwd;
use Carp;

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

use constant DATA_PERMS => 0660;
use constant DIR_PERMS => DATA_PERMS | 0110;
use constant ROOM_PROTO => '/core/roomproto';
use constant TICK_INTERVAL => 30;

%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);

use constant DIST_SINGULAR => 'foot';
use constant DIST_PLURAL => 'feet';

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

use vars qw($log_main $log_report $log_priv $log_edit $log_error $log_opened);
use IO::File;

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

  foreach (values %MConnection::Connections) {
    my $obj = $_->object or next;
    next unless $obj->immortal;
    $obj->send("&fg[[ $str ]]&n");
  }
  my $msg = _logdate() . ": $str\n";
  print STDOUT      $msg;
  return unless $log_opened;
  print $log_main   $msg if $str !~ /^(main loop speed: |Auto zone reset: )/;
  print $log_report $msg if $str =~ /^(\w+ REPORT|KEYWORD):/;
  print $log_priv   $msg if $str =~ /^\(PC\)/;
  print $log_edit   $msg if $str =~ /^EDIT/;
  print $log_error  $msg if $str =~ /^ERROR/;
  1;
}

sub _logdate {
  #return scalar(localtime);
  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 = "data/logs";
  mkdir reldpath($logd), DIR_PERMS;
  $log_main   = IO::File->new(relfpath("$logd/mudlog"),       '>',  DATA_PERMS) or die $!;
  $log_report = IO::File->new(relfpath("$logd/user_reports"), '>>', DATA_PERMS) or die $!;
  $log_priv   = IO::File->new(relfpath("$logd/priv_cmds"),    '>>', DATA_PERMS) or die $!;
  $log_edit   = IO::File->new(relfpath("$logd/edits"),        '>>', DATA_PERMS) or die $!;
  $log_error  = IO::File->new(relfpath("$logd/errors"),       '>>', DATA_PERMS) or die $!;
  foreach ($log_main, $log_report, $log_priv, $log_edit, $log_error) {
    $_->autoflush(1);
  }
  mudlog "--- Log starts ---";
  $log_opened = 1;
}

### Warning hook ##########################################################################################

$SIG{__WARN__} = sub {
  my ($wt) = @_;
  return if $wt =~ /Use of uninitialized value.* during global destruction/;
  (my $lt = $wt) =~ s#\s*\n\s*(\S)# / $1#g;
  $lt =~ s/\n//g;
  #warn $wt;
  mudlog "ERROR/CORE: warning: $lt";
};

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

sub complain {
  carp "complain() is deprecated. use cluck() instead.";
  goto &cluck;
}

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

sub dist_phrase {
  my ($distance) = @_;
  return $distance . ' ' . (abs($distance) == 1 ? DIST_SINGULAR : DIST_PLURAL);
}

sub relfpath ($) {
  my ($path) = @_;
  return File::Spec->catfile(clean_cwd(), split /\//, $path);
}
sub reldpath ($) {
  my ($path) = @_;
  return File::Spec->catdir(clean_cwd(), split /\//, $path);
}

sub clean_cwd () {
  my ($t) = fastcwd() =~ /^(.*)$/;
  $t;
}

sub parse_file_ref {
  my ($str, $ptype) = @_;

  defined $str or do {
    use Carp;
    confess "undef passed to parse_file_ref()";
    return;
  };
  my ($type, $path) = $str =~ /^(?:(\w+):)?([\w\/]+)$/;
  defined $path or return;
  $type ||= $ptype || '';
  $path =~ s#/+$##;
  $path =~ s#/{2,}#/#g;
  my ($file) = $path =~ m#([^/]+)$#;
  my $filepath = '';
  if ($type) {
    my @from = $type eq 'mod' ? ('modules') : $type eq 'txt' ? ('data','texts') : ('data','world');
    my @dirs = map {lc} split(m|/|, $path);
    shift @dirs unless $dirs[0];
    pop @dirs if $type =~ /^(mod|txt)$/;
    ($filepath) = File::Spec->catfile(fastcwd(), @from, @dirs, "$file.$type") =~ /^(.*)$/;
  }
  return (lc $type, lc $path, $filepath);
}

sub make_enclosing {
  my ($self, $path) = @_;

  return unless $path;
  $path =~ s#\w+.\w{1,8}$##;
  File::Path::mkpath($path, 0, DIR_PERMS);
}

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

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

1;
