#!/usr/bin/perl -w 

my $VERSION = '1.99';

## revisions by Sam Denton, aka samwyse; email me at gmail.com
## original program by Nicholas J. Leon, aka mr.nick 

## A text mode client for the Chatter Box of Perl Monks 
## This is not an attempt to be complete, but small and useful 
## Use it or not. No guarantee, no warranty, blah blah 

## Now supports Win32 installations with a different ReadLine call.

## Autoupdate now actually autoupdates

## Oh, and it has no error checking :) 


use strict; 
use XML::Simple; 
use LWP::Simple; 
use LWP::UserAgent; 
use HTTP::Cookies; 
use HTTP::Request::Common; 
use Data::Dumper; 
use Text::Wrap qw($columns wrap); 
use Term::ReadLine; 
use Term::ReadKey qw(GetTerminalSize ReadLine ReadMode); 
use HTML::Parser;
use File::Copy;

$|++; 

my $pm = 'http://www.perlmonks.org/index.pl'; 
my $win32 = ($^O =~ /win32/i);
my $home =  $win32 ?
  ( $ENV{HOME} || $ENV{APPDATA} || $ENV{USERPROFILE} || "." ) :
  ( $ENV{HOME} || "." );

my $cookie = "$home/.pmcookie"; 
my $cffile = "$home/.pmconfig"; 
my %config = ( 
            timestamp => 0, 
            colorize => 1, 
            browser => '/usr/bin/lynx %s', 
            newnodes => 25, 
            updateonlaunch => 0, 
            xponlaunch => 1, 
            whoonlaunch => 1, 
            newnodesonlaunch => 0, 
            timeout => 15, 
            homepage => 'http://www.perlmonks.org/?displaytype=displaycode;node_id=720870', 
           ); 

my %seenmsg; 
my %seenprv; 
my %xp;
my $ua;

## some color stuff (if you want) 
my %colormap =  
  (  
   node => [ "\e[33m", "\e[0m" ], 
   user => [ "\e[1m", "\e[0m" ], 
   code => [ "\e[32m", "\e[0m" ], 
   me => [ "\e[36m", "\e[0m" ], 
   private => [ "\e[35m", "\e[0m" ], 
   important => [ "\e[1;34m", "\e[0m" ], 
  ); 

## <readmore>
######################################################################
######################################################################

sub writeconfig { 
  unless (open(OUT, ">$cffile")) { 
    warn "Couldn't open '$cffile' for writing: $!\n"; 
    return; 
  } 

  print OUT "$_ $config{$_}\n" for keys %config; 

  close OUT; 
} 
sub readconfig { 
  unless (-r $cffile) { 
    warn "'$cffile' does not exist, skipping.\n"; 
    return; 
  } 
  unless (open(IN, $cffile)) { 
    warn "Couldn't open '$cffile' for reading: $!\n"; 
    return; 
  } 

  %config =( %config, (map /^([^\s]+)\s+(.+)$/, <IN>));

  close IN; 
} 

## testing ... autoupdate
sub autoupdate {
  my $quiet = shift;
  my $r = $ua->request(GET "$config{homepage}");
  unless ($r) {
    print "Unable to access the most recent version via the Internet.\n";
    return;
  }
  $r->content =~ /^\s*my\s*\$VERSION\s*=\s*'(\d+\.\d+)'\s*;\s*$/m;
  unless ($1) {
    print "Unable to parse the version number found at $config{homepage}.\n";
    return;
  }
  my $ver = $1;

  print "This version is $VERSION, the most recent version is $ver.\n"
    unless $quiet;

  if ($VERSION >= $ver) {
    print "There is no need to update.\n" unless $quiet;
    return;
  }

  print "Version $ver is available.\n";

  my $tmp = $ENV{TMP} || $ENV{TEMP} || "/tmp";
  my $fn = "$tmp/pmchat-$ver";

  unless (open (OUT, ">$fn")) {
    print "Unable to save newest version to $fn\n";
    return;
  }

  print OUT $r->content;
  close OUT;

  ## a couple checks here: we can autoupdate IF the following are true
  if ($win32) {
    print "Sorry, autoupdate is not available for Windows installations.\n";
    print "The newest version has been saved in $tmp/pmchat.$ver.\n";
    return;
  }

  ## moving the old version someplace else 
  if (!move($0, "$0.bak")) {
    print "Couldn't move $0 to $0.bak, aborting.\n";
    print "The newest version has been saved in $fn.\n";
    return;
  }
  ## moving the new version to the old's location
  if (!move($fn, $0)) {
    print "Couldn't move $fn to $0, aborting $!.\n";
    move("$0.bak", $0);
    print "The newest version has been saved in $fn.\n";
    return;
  }
  ## okay! Reload!
  chmod 0755, $0;
  writeconfig;
  exec $0;
}


######################################################################
######################################################################

sub colorize {
  my $txt = shift;
  my $type = shift;

  return $txt unless $config{colorize};
  return $txt if $win32;

  "$colormap{$type}[0]$txt$colormap{$type}[1]";
}

sub user {
  colorize(shift, "user");
}
sub imp {
  colorize(shift, "important");
}  
sub content {
  my $txt = shift;

  return $txt unless $config{colorize};
  return $txt if $win32;

  unless ($txt =~ s/\<code\>(.*)\<\/code\>/$colormap{code}[0]$1$colormap{code}[1]/mig) {
    $txt =~ s/\[([^\]]+)\]/$colormap{node}[0]$1$colormap{node}[1]/g;
  }

  $txt;
}
######################################################################
######################################################################

sub cookie {
  $ua->cookie_jar(HTTP::Cookies->new());
  $ua->cookie_jar->load($cookie);
}

sub login {
  my $user; 
  my $pass; 

  ## fixed <> to <STDIN> via merlyn
  print "Enter your username: "; chomp($user = <STDIN>); 
  print "Enter your password: ";
  ReadMode 2; chomp($pass = <STDIN>); ReadMode 0;

  $ua->cookie_jar(HTTP::Cookies->new(file => $cookie, 
                                     ignore_discard => 1, 
                                     autosave => 1, 
                                    ) 
                 ); 

  my $r = $ua->request( POST ($pm, [  
                                 op => 'login',  
                                 user => $user,  
                                 passwd => $pass, 
                                 expires => '+1y',  
                                 node_id => '16046'  
                                ])); 
}

sub xp { 
    my $r = $ua->request(GET("$pm?node_id=16046")); 
    my $xml = XMLin($r->content); 

    $config{xp} = $xml->{XP}->{xp} unless defined $config{xp};
    $config{level} = $xml->{XP}->{level} unless defined $config{level};


    print "\nYou are logged in as ".user($xml->{INFO}->{foruser}).".\n"; 
    print "You are level $xml->{XP}->{level} ($xml->{XP}->{xp} XP).\n"; 
    if ($xml->{XP}->{level} > $config{level}) {
      print imp "You have gained a level!\n";
    }
    print "You have $xml->{XP}->{xp2nextlevel} XP left until the next level.\n"; 

    if ($xml->{XP}->{xp} > $config{xp}) {
      print imp "You have gained ".($xml->{XP}->{xp} - $config{xp})." experience!\n";
    }
    elsif ($xml->{XP}->{xp} < $config{xp}) { 
      print imp "You have lost ".($xml->{XP}->{xp} - $config{xp})." experience!\n"; 
    }                               

    ($config{xp}, $config{level}) =( $xml->{XP}->{xp}, $xml->{XP}->{level});

    print "\n"; 
  } 

sub who { 
  my $req = GET("$pm?node_id=15851"); 
  my $res = $ua->request($req); 
  my $ref = XMLin($res->content, forcearray => 1); 

  print "\nUsers current online (";
  print $#{$ref->{user}} + 1;
  print "):\n";

  print wrap "\t", "\t", map { user($_->{username})." " } @{$ref->{user}};

  print "\n";
} 

sub newnodes { 
  my $req = GET("$pm?node_id=30175"); 
  my $res = $ua->request($req); 
  my $ref = XMLin($res->content, forcearray => 1); 
  my $cnt = 1; 
  my %users = map { ($_->{node_id}, $_->{content}) } @{$ref->{AUTHOR}}; 

  print "\nNew Nodes:\n";

  if ($ref->{NODE}) {
    for my $x (sort { $b->{createtime} <=> $a->{createtime} } @{$ref->{NODE}}) { 
      print wrap "\t", "\t\t", 
      sprintf("%d. [%d] %s by %s (%s)\n", $cnt, 
              $x->{node_id}, $x->{content}, 
              user(defined $users{$x->{author_user}} ? $users{$x->{author_user}}:"Anonymous Monk"), 
              $x->{nodetype});
      last if $cnt++ == $config{newnodes}; 
    } 
  }
  print "\n";

} 

######################################################################
######################################################################

sub showmessage {
  my $msg = shift;
  my $type = shift || '';
  my $fmt = "%02d:%02d:%02d ";
  my $tmplt = "A8xA2xA2xA2";

  for my $k (keys %$msg) {
    $msg->{$k} =~ s/^\s+|\s+$//g
  }

  print "\r";

  if ($type eq 'private') {
    print wrap('', "\t", 
               ($config{timestamp}?sprintf $fmt, (unpack($tmplt, $msg->{time}))[1..3]:'').
               colorize("$msg->{author} says $msg->{content}", "private").
               "\n");
  }
  else {
    if ($msg->{content} =~ s/^\/me\b/$msg->{author}/) {
      print wrap('', "\t", 
                 ($config{timestamp}?sprintf $fmt, (unpack($tmplt, $msg->{time}))[1..3]:'').
                 colorize("$msg->{content}", "me"), 
                 "\n");
    }
    else {
      print wrap('', "\t", 
                 ($config{timestamp}?sprintf $fmt, (unpack($tmplt, $msg->{time}))[1..3]:'').
                 colorize($msg->{author}, "user").
                 ": ".
                 content($msg->{content}).
                 "\n");
    }
  }
}


sub getmessages { 
  my $req = GET("$pm?node_id=15834"); 
  my $res = $ua->request($req); 
  my $ref = XMLin($res->content, forcearray => 1 ); 

  if (defined $ref->{message}) { 
    for my $mess (@{$ref->{message}}) { 
      ## ignore this message if we've already printed it out 
      next if $seenmsg{"$mess->{user_id}:$mess->{time}"}++; 

      showmessage $mess; 
    } 
  } 
  else { 
    ## if there is nothing in the list, reset ours 
    undef %seenmsg; 
  } 
} 

sub getprivatemessages { 
  my $req = GET("$pm?node_id=15848"); 
  my $res = $ua->request($req); 
  my $ref = XMLin($res->content, forcearray => 1); 

  if (defined $ref->{message}) { 
    for my $mess (@{$ref->{message}}) { 
      ## ignore this message if we've already printed it out 
      next if $seenprv{"$mess->{user_id}:$mess->{time}"}++; 

      showmessage $mess, "private"; 
    } 
  } 
  else { 
    undef %seenprv; 
  } 
} 

sub postmessage { 
  my $msg = shift; 
  my $req = POST ($pm, [ 
                     op => 'message', 
                     message => $msg, 
                     node_id => '16046', 
                    ]); 

  $ua->request($req); 
} 

sub node {
  my $id = shift;

  system(sprintf($config{browser}, "$pm?node_id = $id"));
}

sub help {
  print <<EOT
The following commands are available:
    /help         :: Shows this message.
    /newnodes     :: Displays a list of the newest nodes (of all types)
                     posted. The number of nodes displayed is limited by
                     the "newnodes" user configurable variable.
    /node ID      :: Retrieves the passed node and launches your user
                     configurable browser ("browser") to view that node.
    /reload       :: UNIX ONLY. Restarts pmchat.
    /set          :: Displays a list of all the user configurable
                     variables and their values.
    /set X Y      :: Sets the user configurable variable X to value Y.
    /update       :: Checks for a new version of pmchat, and if it
                     exists, download it into a temporary location.
                     This WILL NOT overwrite your current version.
    /quit         :: Exits pmchat.
    /who          :: Shows a list of all users currently online.
    /xp           :: Shows your current experience and level.
EOT
  ;
}

######################################################################
######################################################################
my $old;
my $term = new Term::ReadLine 'pmchat';

sub getlineUnix {
  my $message;

  eval {
    local $SIG{ALRM}=sub { 
      $old = $readline::line; 
      die 
    };

    ## I don't use the version of readline from ReadKey (that includes
    ## a timeout) because this version stores the interrupted (what
    ## was already typed when the alarm() went off) text in a variable.
    ## I need that so I can restuff it back in.

    alarm($config{timeout}) unless $win32;
    $message = $term->readline("Talk: ", $old);
    $old = $readline::line = '';
    alarm(0) unless $win32;
  };    

  $message;
}

sub getlineWin32 {
  ## unfortunately, there is no way to preserve what was already typed
  ## when the timeout occured. If you are typing when it happens, 
  ## you lose your text.

  my $message = $term->readline("Talk: ");
  $message;
}

## initialize our user agent
$ua=LWP::UserAgent->new;
$ua->agent("pmchat-samwyse"); 

## trap ^C's
## for clean exit
$SIG{INT}=sub { 

  writeconfig;
  exit 
};

## load up our config defaults
readconfig;

## for text wrapping
$columns = (GetTerminalSize)[0] || $ENV{COLS} || $ENV{COLUMNS} || 80;

if (-e $cookie) {
  cookie;
}
else {
  login;
}

print "This is pmchat version $VERSION.\n";

autoupdate(1) if $config{updateonlaunch};
xp() if $config{xponlaunch};
who() if $config{whoonlaunch};
newnodes() if $config{newnodesonlaunch};
getprivatemessages;
getmessages();
print "Type /help for help.\n";

while (1) {
  getprivatemessages;
  getmessages;

  #my $message = $win32 ? getlineWin32() : getlineUnix();
  my $message = getlineUnix();

  if (defined $message) {
    ## we understand a couple of commands
    $message =~ s/^\s*//;
    if ($message =~ /^\/who\b/i) {
      who;
    }
    elsif ($message =~ /^\/q(uit)?\b/i) {
      writeconfig;
      exit;
    }
    elsif ($message =~ /^\/set\s+([^\s]+)\s+(.+)$/) {
      $config{$1} = $2;
      print "$1 is now $2\n";
    }
    elsif ($message =~ /^\/set$/) {
      my $width = 0;
      map { $width = length() if $width < length() } keys %config;
      for my $k (sort keys %config) {
        printf "\t%-${width}s %s\n", $k, $config{$k};
      }
    }
    elsif ($message =~ /^\/new\s*nodes\b/) {
      newnodes;
    }
    elsif ($message =~ /^\/xp\b/) {
      xp;
    }
    elsif ($message =~ /^\/node\s+(\d+)/) {
      node($1);
    }
    elsif ($message =~ /^\/h(elp)?\b/) {
      help;
    }
    elsif ($message =~ /^\/reload\b/) {
      print "Reloading $0!\n";
      writeconfig;
      exec $0;
    }
    elsif ($message =~ /^\/update\b/) {
      autoupdate;
    }
    elsif ($message =~ /^\/(msg|me|em|tell|(un)?ignore|chattero(ff|n))\b/) {
      postmessage($message);
    }
    elsif ($message =~ /^\//) {
      print "Unknown command '$message'.\n";
    }
    elsif ($message =~ /^\s*$/) {
      ;
    }
    else {
      postmessage($message);
    }
  }
}