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;# Variablesmy $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 membersLines that do not begin with / will be stored in the message bufferand will be sent to destination id when an empty line is entered.This allows you to send a message of multiple lines.EOF# Keyboard commandsmy %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;# Constructorsub 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 STDINsub 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 messagesub 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) = @_;