textconsole.pm

Net-OICQ-1.6

package Net::OICQ::TextConsole;

# $Id: TextConsole.pm,v 1.15 2007/06/15 18:09:53 tans Exp $

# Copyright (c) 2003 - 2007 Shufeng Tan.  All rights reserved.
# 
# This package is free software and is provided "as is" without express
# or implied warranty.  It may be used, redistributed and/or modified
# under the terms of the Perl Artistic License (see
# http://www.perl.com/perl/misc/Artistic.html)

use strict;
use warnings;
use Encode;
use Carp;
use IO::Select;
use Term::ANSIColor;
use Term::ReadKey;

use Net::OICQ;
use Net::OICQ::ServerEvent;
use Net::OICQ::ClientEvent;

our $AUTOLOAD;

# Variables

my $HELP = <<EOF ;
All lines that begin with / (slash) are treated as keyboard commands.

  /help, /?    - print this help message
  /52482796    - set destination id num to a QQ id or a group
  /away        - toggle auto-reply
  /ls [id]     - list id numbers saved in user directory
  /rm [id]     - remove locally saved user info
  /buf         - show message buffer
  /rmbuf       - clear message buffer
  /hist        - show history
  /obj         - show object
  /set         - set object attribute
  /clear       - clear screen

  /plugin /path/to/plugin [id] - load plugin for auto-reply

  /eval perl_one_liner - do whatever you want.  \$oicq and \$ui are pre-defined.

  /xxxxx mesg  - send on-line mesg to xxxx without changing destination id
  /get [id]    - get user info of the specified id (default to yourself)
  /f           - list all friends stored on the server
  /who         - get a list of online friends
  /s [n]       - list n x 25 online users if n < 100, or chekc if [n] is online
  /mode [n|i|a]- change mode to Normal, Invisible or Away
  /update      - update information
  /accept [id] - accept contact from id
  /reject [id] - reject contact from id
  /add [id]    - add a user to friend list
  /del [id]    - delete a user from friend list
  /ban [id]    - forbid a user from contacting you
  /passwd xxxx - change passwd to xxxx
  /ginfo xxxx  - get group info
  /gs xxxx     - search group
  /gwho xxxx   - list online group members

Lines that do not begin with / will be stored in the message buffer
and will be sent to destination id when an empty line is entered.
This allows you to send a message of multiple lines.
EOF

# Keyboard commands

my %KbCmd = (  # Code ref          # Min num of arguments
	help	=> [\&help,	0],
	'?'	=> [\&help,	0],

	get	=> [\&get_user_info,	0],
	f	=> [\&get_friends_list,	0],
	who	=> [\&get_online_friends, 0],
	s	=> [\&search_users,	0],
	mode	=> [\&set_mode,		0],
	update	=> [\&update_info,	0],
	accept	=> [\&accept_contact,	1],
	reject	=> [\&reject_contact,	1],
	add	=> [\&add_contact,	1],
	del	=> [\&del_contact,	1],
	ban	=> [\&forbid_contact,	1],
	passwd	=> [\&set_passwd,	1],
	ginfo	=> [\&get_group_info,	1],
	gs	=> [\&search_group,	1],
	gwho	=> [\&group_online_members, 1],

	away	=> [\&toggle_autoreply,	0],
	ls	=> [\&list_saved_ids,	0],
	strangers => [\&show_strangers,	0],
	rm	=> [\&remove_saved_ids,	1],
	buf	=> [\&show_msg_buffer,	0],
	rmbuf	=> [\&clear_msg_buffer,	0],
	obj	=> [\&show_object,	0],
	set	=> [\&set_attribute,	0],
	plugin	=> [\&load_plugin,	1],
	hist    => [sub { my $ui = shift; foreach my $e (@{$ui->{OICQ}->{EventQueue}}) { $ui->info($e->dump) }}, 0],
	buf     => [sub { print shift->{MsgBuffer}, "\n" }, 0],
	clear	=> [sub {system "clear"}, 0],
);

my %AttrFilter = (
	LogChat      => sub { return $_[0] if $_[0] =~ /^\w*$/; undef },
	Debug        => sub { return $_[0] if $_[0] =~ /^\d$/; undef },
	AutoAwayTime => sub { return $_[0] if $_[0] =~ /^\d+$/; undef },
	Away         => sub { return $_[0] if $_[0] =~ /^\d+$/; undef },
);

my %Color = (
	message => 'blue',
	service => 'yellow',
	info    => 'green',
	warn    => 'yellow bold',
	error   => 'red bold',
	timestamp => 'green',
);

my $InfoHeader  = \@Net::OICQ::InfoHeader;
my $ConnectMode = \%Net::OICQ::ConnectMode;

# Constructor

sub new {
	my ($class, $oicq) = @_;

	defined $oicq or $oicq = new Net::OICQ;
	my $self = {
		OICQ      => $oicq,
		MsgBuffer => "",
		DstId     => "",
		Select    => new IO::Select(),
	};
	$self->{'UTF-8'}  = exists($ENV{LANG}) and defined($ENV{LANG}) and $ENV{LANG} =~ /UTF-8/;
	if ($^O eq 'MSWin32') {
		$ENV{ANSI_COLORS_DISABLED} = "yes";
	} else {
		$self->{Select}->add(\*STDIN);
	};
	return bless($self, $class);
}

sub output_filter {
	my $self = shift;
	$self->{'UTF-8'} || return @_;
	map { encode('utf8', decode('euc-cn', $_)) } @_;
}

sub info {
	my ($self, @text) = @_;
	print color('green'), $self->output_filter(@text), color('reset');
}

sub warn {
	my ($self, @text) = @_;
	print color('yellow'), $self->output_filter(@text), color('reset');
}

sub error {
	my ($self, @text) = @_;
	print color('red'), $self->output_filter(@text), color('reset');
}

sub mesg {
	my ($self, $time, $group, $srcid, $text, $font) = @_;
	($text) = $self->output_filter($text);
	unless (defined $time) {
		print color($Color{'timestamp'}), substr(localtime, 11, 9), color('reset'),
			"$srcid\n$text\n";
		return;
	}
	my $oicq = $self->{OICQ};
	my ($nick) = $self->output_filter($oicq->get_nickname($srcid));
	my $id_color = $self->id_color($srcid);

	my $srcinfo = $oicq->{Info}->{$srcid};
	my $addr = $srcinfo->{Addr} || 'unknown';
	my $ver  = defined $srcinfo->{Client} ? "0x$srcinfo->{Client}" : 'unknown';

	print color($Color{'timestamp'}), substr(localtime($time), 11, 9),
		$group ? "Group $group " : "",
		color($id_color), "$nick($srcid, IP $addr, version $ver)\n", $text, "\n", color('reset');
	if ($font) {
		print color('white'), $self->output_filter($font), color('reset'), "\n";
	}
	return;
}

sub ask {
	my ($self, $prompt, $timeout) = @_;
	defined $timeout or $timeout = 120;
	print color('yellow'), $prompt, color('reset');
	$self->beep;
	my $input;
	eval {
		local $SIG{ALRM} = sub { die };
		alarm $timeout;
		$input = <STDIN>;
		$self->{LastKbInput} = time;
		alarm 0;
	};
	return $input;
}

sub beep {
	print "\007";
}

# Main loop to process both input from $oicq->{Socket} and STDIN

sub loop {
	my ($self) = @_;
	my $oicq = $self->{OICQ};
	my $select = $self->{Select};
	my $socket = $oicq->{Socket};
	$select->add($socket);
	$self->info("Type /help if you need it.\n");
	$self->prompt;
	my $select_t = 60;
	if ($^O eq 'MSWin32') {
		$select_t = 1;
		print "\n", '#'x72, "\n";
		print "You will not be able to enter commands to this console client\n",
			"due to a limitation of Win32 platform.  Please use win32qq script\n",
			"included in this package.\n",
			"本程序在Windows下无法接受用户输入,请使用Net::OICQ包中的另一个程序win32qq。\n",
			'#'x72, "\n\n";
	}
  LOOP: while(1) {
		$oicq->keepalive if time - $oicq->{LastKeepaliveTime} >= 60;
	HANDLE: foreach my $handle ($select->can_read($select_t)) {
			if ($handle eq $socket) {
				my $packet;
				$socket->recv($packet, 0x4000);
			        foreach my $data ($oicq->get_data($packet)) {
					my $event = new Net::OICQ::ServerEvent($data, $oicq);
					next unless defined($event) && defined($event->{Data});
					$event->parse;
					# Each command needs a ui_command method
					my $cmd = "ui_".$event->cmd;
					eval {$self->$cmd($event)};
					print "$@" if $@;
				}
				next HANDLE;
			}
			my $input = <STDIN>;
			next unless defined $input;
			last LOOP if $input =~ /^\/(exit|quit)/;
			$self->process_kbinput($input);
		}
	}
}

sub ui_set_mode {
	my ($self, $event) = @_;
	if ($event->{Data} eq '0') {
		$self->info("Connection mode changed.\n");
	} else {
		$self->info("Server response to mode change: $event->{Data}\n");
	}
}

sub ui_keep_alive { # do nothing
}

sub ui_send_msg {
	my ($self, $event) = @_;
	my $code = $event->{ReturnCode};
	if ($code eq '00') {
		$self->info("Message accepted by server.\n");
	} else {
		$self->info("Server return code: 0x$code\n");
	}
}

# Display message

sub ui_recv_msg {
	my ($self, $event) = @_;
	my $srcid = $event->{SrcId};
	my $dstid = $event->{DstId};
	my $text  = $event->{Mesg};
	$text =~ s|\x14(.)|'/'.unpack("H*", $1)|seg if $text;
	if (!$event->{MsgTime}) {
		$self->mesg(undef, undef, $srcid, $text) if $srcid != 10000;;
		return;
	}
	return if defined($event->{Ignore}) and $event->{Ignore};
	my $time = $event->{MsgTime};
	my $oicq = $self->{OICQ};
	$self->set_dstid($srcid);
	my $group;
	if (defined $event->{GrpId}) {
		$srcid = $event->{SrcId2};
		$group = $event->{GrpId};
	}
	my $font = $event->{FontName};

	my $subtype = $event->{Subtype};
	if (defined $subtype) {
		if (defined($event->{FileName})) {
			$self->mesg($time, $group, $srcid, "would like to send you a file:\n$event->{FileName} $event->{FileSize} bytes. (Request ID 0x$event->{RequestId}, IP $event->{RequestIP})", $font);
		} elsif (defined($event->{VoiceChat})) {
			$self->mesg($time, $group, $srcid, "requested a voice chat:\n$event->{VoiceChat} (Request ID 0x$event->{RequestId}, IP $event->{RequestIP})", $font);
		} elsif (defined($event->{VideoChat})) {
			$self->mesg($time, $group, $srcid, "requested a video chat:\n$event->{VideoChat} (Request ID 0x$event->{RequestId}, IP $event->{RequestIP})", $font);
		} elsif (defined($event->{RequestCancelled})) {
			$self->mesg($time, $group, $srcid, "cancelled request 0x$event->{RequestCancelled}.", $font);
		} else {
			$text =~ s/[\x00-\x08]/_/sg;
			$self->mesg($time, $group, $srcid, $text, $font);
		}
	} else {
		if (defined($event->{Backdrop})) {
			$self->mesg($time, $group, $srcid, "requested backdrop $event->{Backdrop}", $font);
		} elsif (defined($event->{BackdropCancelled})) {
			$self->mesg($time, $group, $srcid, "cancelled backdrop.", $font);
		} else {
			$text =~ s/[\x00-\x08]/_/sg;
			$self->mesg($time, $group, $srcid, $text, $font);
		}
	}
	#$self->beep;

	return 1 if exists($event->{GrpId});

	# First check if we have a chatbot specially for the sender
	my $chatbot = $oicq->{Info}->{$srcid}->{ChatBot};
	# If not, use the global chatbot for everyone
	$chatbot = $oicq->{ChatBot} unless defined $chatbot;
	# Chatbot may be a reference to sub or a perl script file
	if (defined $chatbot) {
		if (ref($chatbot) eq 'CODE') {
			eval { $chatbot->($event) };
		} elsif (-f $chatbot) {
			eval { require $chatbot; on_message($event) };
		} else {
			return 1;
		}
		if ($@) {
			$oicq->log_t("Chatbot error: $@");
			$self->error("Chatbot error: $@\n");
		}
	}
}

sub ui_get_user_info {
	my ($self, $event) = @_;
	my $field = $event->{Info};
	my $oicq = $self->{OICQ};
	if ($field->[0] eq $oicq->{Id} && @{$oicq->{EventQueue}} < 10) {
		# Dont display user info requested immediately after login
		$self->info("Retrieved info about self $field->[0]\n");
		return;
	}
	$self->info('-'x34, ' User Info ', '-'x34, "\n");
	foreach my $i (0..24) { 
		$field->[$i] =~ s/([\x00-\x1f])/'\x'.unpack("H*", $1)/ge;
		$self->info(sprintf("%-15s: %-25s", $InfoHeader->[$i], $field->[$i]));
		if (defined $field->[$i+25]) {
			$self->info(sprintf(" %-15s: %s\n",
		        		$InfoHeader->[$i+25], $field->[$i+25]));
		} else {
			$self->info("\n");
		}
	}
	$self->info('='x79, "\n");
}

sub ui_get_online_friends {
	my ($self, $event) = @_;
	my $aref = $event->{OnlineFriends};
	my $oicq = $self->{OICQ};
	if (@$aref == 0) {
		$self->info("No friend online.\n");
		return;
	}
	$self->info(sprintf "%-9s %-12s %-20s %s\n", 'Id', 'Nickname', 'Address', 'Mode');
	$self->info(sprintf "%9s %-12s %-20s %s\n", '-'x9, '-'x12, '-'x20, '----');
	foreach my $fid (@$aref) {
		my $info = $oicq->{Info}->{$fid};
		my $addr = $info->{Addr} || "";
		my $mode = $info->{Mode};
		#next if $fid >= 72000001 and $fid <= 72000012;
		my $nick = $oicq->get_nickname($fid);
		$self->info(sprintf "%9d %-12s %-20s %d\n", $fid, $nick, $addr, $mode);
	}
	$self->info('='x48,"\n");
}

sub ui_search_users {
	my ($self, $event) = @_;
	my $aref = $event->{UserList};
	unless (@$aref) {
		$self->info("No result for user search\n");
		return;
	}
	$self->info('-'x32, ' Search Result ', '-'x32, "\n");
	foreach my $ref (@$aref) {
		$self->info(sprintf("%-10s %-40s %+20s %4s\n",
				map {s/([\x00-\x1f])/'\x'.unpack("H*", $1)/ge; $_} @$ref));
	}       
	$self->info('='x79, "\n");  
}       

sub ui_get_friends_list {
	my ($self) = @_;
	$self->info('-'x25, " Friends List ", '-'x25, "\n");
	my $info = $self->{OICQ}->{Info};
	my $idx = 1;
	foreach my $id (sort {$a <=> $b} keys %$info) {
		my $hashref = $info->{$id};
		next unless defined $hashref->{Friend};
		$self->info(sprintf "%2d.  %9d  %3s  %3s  %4s : %-16s %s\n",
			$idx++, $id,
			defined($hashref->{Sex}) ? $hashref->{Sex} : '',
			defined($hashref->{Age}) ? $hashref->{Age} : '',
			defined($hashref->{Face}) ? $hashref->{Face} : '',
			defined($hashref->{Nickname}) ? $hashref->{Nickname} : '',
			defined($hashref->{Unknown}) ? $hashref->{Unknown} : '');
	}
	$self->info('='x65, "\n");
}

sub ui_recv_friend_status {
	my ($self, $event) = @_;
	my $id = $event->{SrcId};
	my $mode = $event->{Mode};
	my $addr = $event->{Addr};
	$addr = "" unless defined $addr;
	$self->info(substr(localtime, 11, 9), $id, " ",
		        $self->{OICQ}->get_nickname($id), " $addr ");
	if ($mode == 10) {
		$self->info("is online.\n");
	} elsif ($mode == 20) {
		$self->info("is offline or wishes to be invisable :-)\n");
	} elsif ($mode == 30) {
		$self->info("is away.\n");
	} else {
		$self->info("changed mode to $mode\n");
	}
}

sub ui_recv_service_msg {
	my ($self, $event) = @_;
	$self->info("System message from $event->{SrcId}: $event->{Comment}\n",
			defined($event->{Mesg}) ? "($event->{Mesg})" : "", "\n");
}

sub ui_do_group {
	my ($self, $event) = @_;
	my $oicq = $self->{OICQ};
	my $subcmd = $event->{SubCmd};
	if ($subcmd =~ /^[01]a/) {  # group message
		if ($event->{Reply} eq '00') {
			$self->info("Group message sent\n");
		} else {
			$self->info("Server return code: $event->{Reply}\n");
		}
	} elsif ($subcmd eq '0b') {
		if ($event->{Reply} eq '00') {
			my @online_member = map {$oicq->get_nickname($_)."($_)"} @{$event->{OnlineMembers}};
			$self->info("Group $event->{GrpIntId} online members: @online_member\n");
		} else {
			$self->info("Server reply: $event->{Error}\n");
		}
	} else {
		$self->info($event->dump);
	}
}

sub ui_add_contact_1 {
	my ($self, $event) = @_;
	$self->info("$event->{Comment}\n");
}

sub ui_add_contact_2 {
	my ($self, $event) = @_;