#!/usr/bin/perl -w
# keine.pl - Don Yang (uguu.org)
#
# Interactive:
#  ./keine.pl log.txt
#
# Summarize report and exit:
#  ./keine.pl < log.txt
#
# 09/16/07

use strict;
use Time::Local;
use Term::ReadLine;
use constant LOG_START => "{{{";
use constant LOG_END => "}}}";
use constant PROMPT => "> ";
use constant MAX_RECENT_EVENTS => 5;
use constant SHOW_PERCENT_THRESHOLD => 0.01;

my ($LogFile);    # Log file name
my (@Log);        # (timestamp, event) list
my (%Dict);       # (shorthand -> event)
my ($Output);     # Output handle
my ($Term);       # ReadLine handle

# Check if program is being used interactively
sub Interactive()
{
   return defined($Term);
}

# Read a single line from stdin
sub ReadLine()
{
   return $Term->readline(PROMPT) if Interactive();
   return scalar <STDIN>;
}

# Format scalar time to string time
sub EncodeTime($)
{
   my ($s, $m, $h, $day, $month, $year) = localtime $_[0];
   return
      sprintf '%04d-%02d-%02d %02d:%02d:%02d',
              $year + 1900, $month + 1, $day, $h, $m, $s;
}

# Convert string time to UTC seconds.
# Accepted times:
#  yyyy-mm-dd HH:MM:SS
#  yyyy-mm-dd HH:MM
#  HH:MM:SS
#  HH:MM
sub DecodeTime($$)
{
   my ($reference_time, $time_str) = @_;

   # Check for fully specified time
   if( $time_str =~ /(\d{4})-(\d{1,2})-(\d{1,2})\s
                     (\d{1,2}):(\d{1,2}):(\d{1,2})/x )
   {
      return timelocal($6, $5, $4, $3, $2 - 1, $1 - 1900);
   }
   if( $time_str =~ /(\d{4})-(\d{1,2})-(\d{1,2}) (\d{1,2}):(\d{1,2})/ )
   {
      return timelocal(0, $5, $4, $3, $2 - 1, $1 - 1900);
   }

   # Partially specified time, use date from reference time.
   return undef unless defined $reference_time;
   my ($s, $m, $h, $day, $month, $year) = localtime $reference_time;
   if( $time_str =~ /(\d{1,2}):(\d{1,2}):(\d{1,2})/ )
   {
      ($h, $m, $s) = ($1, $2, $3);
   }
   elsif( $time_str =~ /(\d{1,2}):(\d{1,2})/ )
   {
      ($h, $m) = ($1, $2);
   }
   else
   {
      return undef;
   }

   # Reconstruct time so that it's past the reference time
   my $time = timelocal($s, $m, $h, $day, $month, $year);
   return undef unless defined $time;
   if( $time < $reference_time )
   {
      if( $time >= $reference_time - 60 )
      {
         $time = $reference_time;
      }
      else
      {
         $time += 86400;
      }
   }
   return $time;
}

# Format a single time duration as a string
sub FormatTimeLength($)
{
   my ($t) = @_;
   my $m = int($t / 60);
   return sprintf('%8d (%dh %dm)', $t, int($m / 60), $m % 60);
}

# Strip excessive whitespaces from string
sub CleanString($)
{
   my ($s) = @_;
   $s =~ s/^\s*(.*?)\s*$/$1/s;
   $s =~ s/\s+/ /g;
   return $s;
}

# Append line to log file and flush immediately
sub WriteLogLine($)
{
   my ($line) = @_;
   my ($file);
   open $file, ">> $LogFile" or die $!;
   print $file $line;
   close $file or die $!;
}

# Load a single log line from file
sub ReadLogLine($$)
{
   my ($reference_time, $line) = @_;
   if( $line =~ /^\s*#\s*(\S+)\s*=\s*(\S.*)$/ )
   {
      # Add abbreviation
      $Dict{$1} = CleanString($2);
      return;
   }
   if( $line =~ /^\s*(\d\S+ \d+:\d\S+|\d\S+)\s+(\S.*)$/ )
   {
      # Parse log line
      my ($time, $event) = (DecodeTime($$reference_time, $1), CleanString($2));
      if( !defined($time) ||
          (defined $$reference_time && $time < $$reference_time) )
      {
         print $Output "Ignored line $. due to invalid timestamp\n";
         return;
      }

      # Add log line and update reference time
      push @Log, [$time, $event];
      $$reference_time = $time;

      # Add event to history
      if( Interactive() && $event ne LOG_START && $event ne LOG_END )
      {
         $Term->addhistory($event);
      }
   }
}

# Load log file from disk, or initialize new log file
sub LoadLogFromFile($)
{
   my ($last_timestamp) = @_;
   my ($file);

   @Log = ();
   %Dict = ();
   $$last_timestamp = undef;
   if( open $file, "< $LogFile" )
   {
      # Load log from disk
      while(my $line = <$file>)
      {
         chomp $line;
         ReadLogLine($last_timestamp, $line);
      }
      close $file;
      print $Output "Loaded ", $#Log + 1, " events from $LogFile\n";
   }
   else
   {
      # Start empty log
      print $Output "Starting new log $LogFile\n";
   }
}

# Load log from stdin
sub LoadLogFromStdin()
{
   my $last_timestamp = undef;
   @Log = ();
   %Dict = ();
   while(my $line = <>)
   {
      chomp $line;
      ReadLogLine(\$last_timestamp, $line);
   }
}

# Find last command in log matching key.  If nothing matched, print
# error message and return undef.
sub FindLastCommand($$)
{
   my ($key, $prefix) = @_;

   for(my $i = $#Log; $i >= 0; $i--)
   {
      my $event = $Log[$i][1];
      my $index = index($event, $key);
      if( $index >= 0 )
      {
         next if $prefix && $index != 0;
         return $event;
      }
   }

   print $Output
      "No previous event with ",
      ($prefix ? "prefix" : "substring"), " $key\n";
   return undef;
}

# Check that prefix matched at word boundaries
sub PrefixWordsMatched($$)
{
   my ($input, $prefix) = @_;
   my $prefix_length = length($prefix);
   if( length($input) == $prefix_length )
   {
      return $input eq $prefix;
   }
   return substr($input, 0, $prefix_length) eq $prefix &&
          substr($input, $prefix_length, 1) eq " ";
}

# Find longest prefix in a dictionary
sub LongestPrefix($)
{
   my ($dict) = @_;
   die unless( (scalar keys %$dict) > 0 );

   my (@prefix);
   foreach my $key (keys %$dict)
   {
      if( $#prefix < 0 )
      {
         # First key, build list of prefixes
         my @tokens = split / /, $key;
         push @prefix, $tokens[0];
         for(my $i = 1; $i <= $#tokens; $i++)
         {
            push @prefix, $prefix[$#prefix] . ' ' . $tokens[$i];
         }
      }
      else
      {
         # Remaining keys, trim prefixes until longest match
         for(my $p = $prefix[$#prefix]; !PrefixWordsMatched($key, $p);)
         {
            pop @prefix;
            $p = $prefix[$#prefix];
         }
      }
   }

   # Return longest prefix
   return $prefix[$#prefix];
}

# Output times for a single event
sub OutputEvent($$$$)
{
   my ($level, $event, $time, $total) = @_;
   print $Output ("   " x $level), FormatTimeLength($time), ": $event";

   # Output ratio for toplevel events, or events that took significant time
   if( $total > 0 && ($level == 0 || $time >= $total * SHOW_PERCENT_THRESHOLD) )
   {
      printf $Output '  [%.1f%%]', 100 * $time / $total;
   }
   print $Output "\n";
}

# Comparator for sorting events
sub CompareEvents($$$$)
{
   my ($value_a, $value_b, $key_a, $key_b) = @_;
   my $c = ($value_b <=> $value_a);
   return ($c != 0) ? $c : ($key_a cmp $key_b);
}

# Show times for a subset of events
sub ShowSubReport($$$$);
sub ShowSubReport($$$$)
{
   my ($events, $total, $skip_parent, $level) = @_;

   # Group events by prefixes
   my (%nodes, %child);
   foreach my $key (keys %$events)
   {
      next if length($key) < $skip_parent;
      my $subkey = substr($key, $skip_parent);
      my ($head) = (($subkey =~ /^(\S+)\s/) ? $1 : $subkey);
      $nodes{$head} += $$events{$key};
      $child{$head}{$key} = 1;
   }

   # Output events sorted by time
   foreach my $n (sort {CompareEvents($nodes{$a}, $nodes{$b}, $a, $b)}
                  keys %nodes)
   {
      if( (scalar keys %{$child{$n}}) == 1 )
      {
         # Only one event with this prefix
         my $k;
         $k = $_ foreach keys %{$child{$n}};
         OutputEvent($level, substr($k, $skip_parent), $nodes{$n}, $total);
      }
      else
      {
         # Output total time for prefix
         my $prefix = LongestPrefix($child{$n});
         OutputEvent($level, substr($prefix, $skip_parent), $nodes{$n}, $total);

         # Recurse to subevents
         my %child_events;
         foreach my $k (keys %{$child{$n}})
         {
            $child_events{$k} = $$events{$k};
         }
         ShowSubReport(\%child_events, $total, length($prefix) + 1, $level + 1);

         # Add an extra newline to make toplevel events stand out
         print $Output "\n" if $level == 0;
      }
   }
}

# Show report
sub ShowReport()
{
   # Get times for all log events
   my (%events, $total_time);
   my ($current_time, $current_event) = (undef, undef);
   $total_time = 0;
   foreach my $i (@Log)
   {
      my ($next_time, $next_event) = @$i;

      # Add times to current event
      if( defined $current_event )
      {
         $events{$current_event} += $next_time - $current_time;
         $total_time += $next_time - $current_time;
      }

      # Set next event
      if( $next_event ne LOG_START && $next_event ne LOG_END )
      {
         $current_event = $next_event;
      }
      else
      {
         $current_event = undef;
      }
      $current_time = $next_time;
   }

   # Add last event
   if( defined $current_event )
   {
      my $delta = time - $current_time;
      $events{$current_event} += $delta;
      $total_time += $delta;
   }

   # Summarize events recursively
   print $Output "Total time: ", FormatTimeLength($total_time), "\n";
   ShowSubReport(\%events, $total_time, 0, 0);
}

# Show help message
sub ShowHelp()
{
   # List of commands
   print $Output <<'EOT';
Commands:
   task        Record context switch to "task"
   . prefix    Record context switch to previous task matching "prefix"
   / substr    Record context switch to previous task containing "substr"

   key=task    Define abbreviation and record task
   # key=task  Define abbreviation without recording task

   ?                 Show commands and abbreviations
   !                 Reload events and abbreviations from file
   (empty string)    Show stats
   (EOF)             Exit
EOT

   # Abbreviations
   if( scalar keys %Dict )
   {
      print $Output "Abbreviations:\n";
      foreach my $key (sort keys %Dict)
      {
         print $Output "   $key = $Dict{$key}\n";
      }
   }

   # Recent events
   my @recent_events;
   for(my $i = $#Log; $i >= 0; $i--)
   {
      if( $Log[$i][1] ne LOG_START && $Log[$i][1] ne LOG_END )
      {
         push @recent_events, [$Log[$i][0], $Log[$i][1]];
         last if $#recent_events == MAX_RECENT_EVENTS - 1;
      }
   }
   if( $#recent_events >= 0 )
   {
      print $Output "Recent events:\n";
      foreach my $i (reverse @recent_events)
      {
         print $Output EncodeTime($$i[0]), " ", $$i[1], "\n";
      }
   }
}

# Execute command
sub ExecuteCommand($$$)
{
   my ($time, $command, $echo) = @_;

   if( $command =~ /^(\S+)\s*=\s*(\S.*)$/ )
   {
      # Add and expand abbreviation
      $Dict{$1} = $2;
      $command = $2;
      WriteLogLine("# $1 = $2\n");
   }
   elsif( $command =~ /^\s*#\s*(\S+)\s*=\s*(\S.*)$/ )
   {
      # Add abbreviation without recording event
      $Dict{$1} = $2;
      WriteLogLine("# $1 = $2\n");
      return;
   }
   elsif( $command =~ /^\.(.*)$/ )
   {
      # Find previous event matching prefix
      $command = FindLastCommand($1, 1);
      return unless defined $command;
   }
   elsif( $command =~ /^\/(.*)$/ )
   {
      # Find previous event containing substring
      $command = FindLastCommand($1, 0);
      return unless defined $command;
   }
   else
   {
      # Expand command
      if( exists $Dict{$command} )
      {
         $command = $Dict{$command};
      }
   }

   # Record and echo command
   push @Log, [$time, $command];
   my $line = EncodeTime($time) . " $command\n";
   WriteLogLine($line);
   print $Output $line if $echo;
}

# Stop writing to log and exit
sub CloseLog()
{
   ExecuteCommand(time, LOG_END, 0);
   WriteLogLine("\n");
   print $Output "\nStopped logging to $LogFile\n";
   exit 0;
}

# Read commands over and over
sub InputLoop($)
{
   my ($last_timestamp) = @_;

   print $Output "Enter ? for help\n";
   ExecuteCommand(time, LOG_START, 0);
   my $command;
   while( defined($command = ReadLine()) )
   {
      # Clean whitespaces
      $command = CleanString($command);

      # Execute special commands
      if( $command eq "" )
      {
         ShowReport();
         next;
      }
      if( $command eq "?" )
      {
         ShowHelp();
         next;
      }
      if( $command eq "!" )
      {
         LoadLogFromFile(\$last_timestamp);
         next;
      }

      # Expand timestamp
      my $time = time;
      if( $command =~ s/^(\d\S+ \d+:\d\S+|\d\S+)\s+(\S.*)$/$2/ )
      {
         my $t = $1;
         my $new_time = DecodeTime($last_timestamp, $t);
         if( !defined($new_time) || $new_time > $time )
         {
            print $Output "Invalid timestamp $t\n";
            next;
         }
         $time = $new_time;
      }

      # Record command
      $last_timestamp = $time;
      ExecuteCommand($time, $command, 1);
   }
   CloseLog();
}

# Program entry
sub main()
{
   # Set default output handle
   $Output = \*STDOUT;

   if( $#ARGV < 0 )
   {
      # Non-interactive use
      if( -t STDIN )
      {
         # Print help message and exit
         print $Output <<"EOT";
Usage:
  $0 log.txt     Start interactive session, recording to log.txt
  $0 < log.txt   Process log.txt, print summary and exit.
EOT
      }
      else
      {
         # Process events from stdin and print report
         LoadLogFromStdin();
         ShowReport();
      }
   }
   else
   {
      # Interactive use
      if( -t STDIN )
      {
         $Term = new Term::ReadLine "Keine";
         $Term->ornaments(0);
         $Output = $Term->OUT if defined $Term->OUT;
      }
      $LogFile = $ARGV[0];

      # Trap SIGINT for clean exit.  Doesn't actually help much, since
      # SIGINT is already intercepted when we use ReadLine.
      $SIG{'INT'} = "CloseLog";

      # Start loop
      my $last_timestamp;
      LoadLogFromFile(\$last_timestamp);
      InputLoop($last_timestamp);
   }
}

main();