1package Bitflu::AdminTelnet;
2####################################################################################################
3#
4# This file is part of 'Bitflu' - (C) 2006-2011 Adrian Ulrich
5#
6# Released under the terms of The "Artistic License 2.0".
7# http://www.opensource.org/licenses/artistic-license-2.0.php
8#
9
10use strict;
11use Encode;
12use constant _BITFLU_APIVERSION => 20120529;
13
14use constant ANSI_ESC    => "\x1b[";
15use constant ANSI_BOLD   => '1;';
16
17use constant ANSI_BLACK  => '30m';
18use constant ANSI_RED    => '31m';
19use constant ANSI_GREEN  => '32m';
20use constant ANSI_YELLOW => '33m';
21use constant ANSI_BLUE   => '34m';
22use constant ANSI_CYAN   => '35m';
23use constant ANSI_WHITE  => '37m';
24use constant ANSI_RSET   => '0m';
25
26
27use constant KEY_C_LEFT  => 100;
28use constant KEY_C_RIGHT => 99;
29use constant KEY_LEFT    => 68;
30use constant KEY_RIGHT   => 67;
31use constant KEY_DOWN    => 66;
32use constant KEY_UP      => 65;
33use constant KEY_TAB     => 9;
34use constant KEY_CTRLA   => 1;
35use constant KEY_CTRLC   => 3;
36use constant KEY_CTRLD   => 4;
37use constant KEY_CTRLE   => 5;
38use constant KEY_CTRLL   => 12;
39
40use constant PROMPT => 'bitflu> ';
41
42use constant NOTIFY_BUFF => 20;
43
44##########################################################################
45# Register this plugin
46sub register {
47	my($class,$mainclass) = @_;
48	my $self = { super => $mainclass, notifyq => [], notifyi => 0, sockbuffs => {} };
49	bless($self,$class);
50
51
52	my $xconf = { telnet_port=>4001, telnet_bind=>'127.0.0.1', telnet_maxhist=>20 };
53	my $lock  = { telnet_port=>1,    telnet_bind=>1                               };
54	foreach my $funk (keys(%$xconf)) {
55		my $this_value = $mainclass->Configuration->GetValue($funk);
56
57		if(defined($this_value)) {
58			$xconf->{$funk} = $this_value;
59		}
60		else {
61			$mainclass->Configuration->SetValue($funk,$xconf->{$funk});
62		}
63		$mainclass->Configuration->RuntimeLockValue($funk) if $lock->{$funk};
64	}
65
66
67
68	my $sock = $mainclass->Network->NewTcpListen(ID=>$self, Port=>$xconf->{telnet_port}, Bind=>$xconf->{telnet_bind}, DownThrottle=>0,
69	                                             MaxPeers=>5, Callbacks =>  {Accept=>'_Network_Accept', Data=>'_Network_Data', Close=>'_Network_Close'});
70	unless($sock) {
71		$self->stop("Unable to bind to $xconf->{telnet_bind}:$xconf->{telnet_port} : $!");
72	}
73
74	$self->info(" >> Telnet plugin ready, use 'telnet $xconf->{telnet_bind} $xconf->{telnet_port}' to connect.");
75	$mainclass->AddRunner($self);
76	$mainclass->Admin->RegisterNotify($self, "_Receive_Notify");
77	return $self;
78}
79
80##########################################################################
81# Register  private commands
82sub init {
83	my($self) = @_;
84	$self->{super}->Admin->RegisterCommand('vd' ,       $self, '_Command_ViewDownloads', 'Display download queue');
85	$self->{super}->Admin->RegisterCommand('ls' ,       $self, '_Command_ViewDownloads', 'Display download queue');
86	$self->{super}->Admin->RegisterCommand('list' ,     $self, '_Command_ViewDownloads', 'Display download queue');
87	$self->{super}->Admin->RegisterCommand('notify',    $self, '_Command_Notify'              , 'Sends a note to other connected telnet clients');
88	$self->{super}->Admin->RegisterCommand('details',   $self, '_Command_Details'             , 'Display verbose information about given queue_id');
89	$self->{super}->Admin->RegisterCommand('crashdump', $self, '_Command_CrashDump'           , 'Crashes bitflu');
90	$self->{super}->Admin->RegisterCommand('quit',      $self, '_Command_BuiltinQuit'         , 'Disconnects current telnet session');
91	$self->{super}->Admin->RegisterCommand('grep',      $self, '_Command_BuiltinGrep'         , 'Searches for given regexp');
92	$self->{super}->Admin->RegisterCommand('sort',      $self, '_Command_BuiltinSort'         , 'Sort output. Use "sort -r" for reversed sorting');
93	$self->{super}->Admin->RegisterCommand('head',      $self, '_Command_BuiltinHead'         , 'Print the first 10 lines of input');
94	$self->{super}->Admin->RegisterCommand('tail',      $self, '_Command_BuiltinTail'         , 'Print the last 10 lines of input');
95	$self->{super}->Admin->RegisterCommand('repeat',    $self, '_Command_BuiltinRepeat'       , 'Executes a command each second');
96	$self->{super}->Admin->RegisterCommand('clear',     $self, '_Command_Clear'               , 'Clear telnet screen');
97	$self->{super}->Admin->RegisterCompletion($self, '_Completion');
98	return 1;
99}
100
101
102##########################################################################
103# Returns a suggestion list
104sub _Completion {
105	my($self,$hint) = @_;
106
107	my @list   = ();
108
109	if($hint eq 'cmd') {
110		@list = keys(%{$self->{super}->Admin->GetCommands});
111	}
112	else {
113		my $ql     = $self->{super}->Queue->GetQueueList;
114		foreach my $qt (keys(%$ql)) {
115			foreach my $qi (keys(%{$ql->{$qt}})) {
116				push(@list,$qi);
117			}
118		}
119	}
120	return @list;
121}
122
123##########################################################################
124# This should never get called.. but if someone dares to do it...
125sub _Command_BuiltinQuit {
126	my($self) = @_;
127	return({MSG=>[[2, "This is a builtin command of ".__PACKAGE__]], SCRAP=>[]});
128}
129
130##########################################################################
131# Non-Catched (= Unpiped) grep command
132sub _Command_BuiltinGrep {
133	my($self) = @_;
134	return({MSG=>[[2, "grep must be used after a pipe. Example: help | grep [-v] peer"]], SCRAP=>[]});
135}
136
137##########################################################################
138# Non-Catched (= Unpiped) sort command
139sub _Command_BuiltinSort {
140	my($self) = @_;
141	return({MSG=>[[2, "tail must be used after a pipe. Example: help | tail"]], SCRAP=>[]});
142}
143
144##########################################################################
145# Non-Catched (= Unpiped) sort command
146sub _Command_BuiltinHead {
147	my($self) = @_;
148	return({MSG=>[[2, "head must be used after a pipe. Example: help | head"]], SCRAP=>[]});
149}
150
151##########################################################################
152# Non-Catched (= Unpiped) sort command
153sub _Command_BuiltinTail {
154	my($self) = @_;
155	return({MSG=>[[2, "sort must be used after a pipe. Example: help | sort"]], SCRAP=>[]});
156}
157
158##########################################################################
159# Clear screen
160sub _Command_Clear {
161	my($self) = @_;
162	return({MSG=>[[0xff, '']], SCRAP=>[]});
163}
164
165##########################################################################
166# Non-Catched (= Unpiped) repeat command
167sub _Command_BuiltinRepeat {
168	my($self) = @_;
169	return({MSG=>[[2, "repeat requires an argument. Example: repeat clear ; date ; vd"]], SCRAP=>[]});
170}
171
172sub _Command_CrashDump  {
173	my($self) = @_;
174
175	open(X, ">", "./workdir/tmp/crash.dump.$$") or die;
176	print X Data::Dumper::Dumper($self);
177	close(X);
178	$self->panic("Whee");
179}
180
181
182##########################################################################
183# Display details
184sub _Command_Details {
185	my($self, @args) = @_;
186
187	my @MSG    = ();
188	my @SCRAP  = ();
189	my $NOEXEC = '';
190	$self->{super}->Tools->GetOpts(\@args);
191
192	if($args[0]) {
193		foreach my $sha1 (@args) {
194			if(my $so        = $self->{super}->Storage->OpenStorage($sha1)) {
195				my $stats      = $self->{super}->Queue->GetStats($sha1);
196				my $rrating    = sprintf("%.1f", $so->GetRemoteRating);
197				   $rrating    = ($rrating > 0 ? $rrating : 'unknown');
198				my $lrating    = ($so->GetLocalRating || 'not rated');
199
200				push(@MSG, [6, "Details for $sha1"]);
201				push(@MSG, [6, ("-" x 52)]);
202				push(@MSG, [0, sprintf("Name                   : %s", $so->GetSetting('name'))]);
203				push(@MSG, [0, sprintf("Download hash          : %s", "sha1:$sha1 magnet:?xt=urn:btih:".$self->{super}->Tools->encode_b32(pack("H*",$sha1)) )]);
204				push(@MSG, [0, sprintf("Filecount              : %d", $so->GetFileCount)]);
205				push(@MSG, [0, sprintf("Total size             : %.2f MB / %d piece(s)",       $stats->{total_bytes}/1024/1024,$stats->{total_chunks})]);
206				push(@MSG, [0, sprintf("Completed              : %.2f MB / %d piece(s)",       $stats->{done_bytes}/1024/1024, $stats->{done_chunks})]);
207				push(@MSG, [0, sprintf("Uploaded               : %.2f MB",                     $stats->{uploaded_bytes}/1024/1024)]);
208				push(@MSG, [0, sprintf("Peers                  : Connected: %d / Active: %d",  $stats->{clients}, $stats->{active_clients})]);
209				push(@MSG, [0, sprintf("Rating                 : %s (own rating: %s)", $rrating, $lrating)]);
210				push(@MSG, [0, sprintf("Downloading since      : %s", ($so->GetSetting('createdat') ? "".localtime($so->GetSetting('createdat')) : 'Unknown'))]);
211				push(@MSG, [0, sprintf("Last piece received at : %s", ($so->GetSetting('_last_recv') ? "".localtime($so->GetSetting('_last_recv')) : '-'))]);
212				push(@MSG, [0, sprintf("Fully downloaded       : %s", ($stats->{done_chunks} == $stats->{total_chunks} ? "Yes" : "No"))]);
213				push(@MSG, [0, sprintf("Download committed     : %s", ($so->CommitFullyDone ? 'Yes' : 'No'))]);
214				push(@MSG, [0, sprintf("Uses sparsefile        : %s", ($so->UsesSparsefile ? 'Yes' : 'No'))]);
215			}
216			else {
217				push(@SCRAP, $sha1);
218			}
219		}
220	}
221	else {
222		$NOEXEC .= "Usage: details queue_id [queue_id2 ...]";
223	}
224	return({MSG=>\@MSG, SCRAP=>\@SCRAP, NOEXEC=>$NOEXEC });
225}
226
227##########################################################################
228# Display current downloads
229sub _Command_ViewDownloads {
230	my($self) = @_;
231
232	my @a            = ([1, "Dummy"]);
233	my $qlist        = $self->{super}->Queue->GetQueueList;
234	my $active_peers = 0;
235	my $total_peers  = 0;
236	my @order        = qw(type name hash peers pieces bytes percent ratio up down eta note);
237	my $header       = { type=>'[Type]', name=>'Name                     ',
238	                     hash=>'/================ Hash ================\\', peers=>' Peers',
239	                     pieces=>' Pieces', bytes=>' Done (MB)', percent=>' Done',
240	                     ratio=>'Ratio', up=>' Up', down=>' Down','note'=>'', eta=>'ETA' };
241	my @items        = ({vrow=>1, rsep=>' '}, map({$header->{$_}} @order));
242	push(@a, [undef, \@items]);
243
244	foreach my $dl_type (sort(keys(%$qlist))) {
245		foreach my $key (sort(keys(%{$qlist->{$dl_type}}))) {
246			my $this_stats = $self->{super}->Queue->GetStats($key)      or $self->panic("$key has no stats!");                 # stats for this download
247			my $this_so    = $self->{super}->Storage->OpenStorage($key) or $self->panic("Unable to open storage of $key");     # storage-object for this download
248			my $xcolor     = 2;                                                                                                # default is red
249			my $ll         = {};                                                                                               # this line
250			my @xmsg       = ();                                                                                               # note-message
251
252			# Set color and note-message
253			if(my $ci = $this_so->CommitIsRunning) { push(@xmsg, "Committing file $ci->{file}/$ci->{total_files}, ".int(($ci->{total_size}-$ci->{written})/1024/1024)." MB left"); }
254			if($this_so->CommitFullyDone)                                    { $xcolor = 3 }
255			elsif($this_stats->{done_chunks} == $this_stats->{total_chunks}) { $xcolor = 4 }
256			elsif($this_stats->{active_clients} > 0 )                        { $xcolor = 1 }
257			elsif($this_stats->{clients} > 0 )                               { $xcolor = 0 }
258			$active_peers += $this_stats->{active_clients};
259			$total_peers  += $this_stats->{clients};
260
261			if($self->{super}->Queue->IsPaused($key)) {
262				my $ptxt = ($self->{super}->Queue->IsAutoPaused($key) ? "AutoPaused" : "Paused");
263				push(@xmsg,$ptxt);
264			}
265
266			$self->{super}->Tools->GetETA($key);
267
268			$ll->{type}   = sprintf("[%4s]",$dl_type);
269			$ll->{name}   = $this_so->GetSetting('name');
270			$ll->{hash}   = $key;
271			$ll->{peers}  = sprintf("%3d/%2d",$this_stats->{active_clients},$this_stats->{clients});
272			$ll->{pieces} = sprintf("%5d/%5d",$this_stats->{done_chunks}, $this_stats->{total_chunks});
273			$ll->{bytes}  = sprintf("%7.1f/%7.1f", ($this_stats->{done_bytes}/1024/1024), ($this_stats->{total_bytes}/1024/1024));
274			$ll->{percent}= sprintf("%4d%%", (($this_stats->{done_chunks}/$this_stats->{total_chunks})*100));
275			$ll->{ratio}  = sprintf("%.2f", ($this_stats->{uploaded_bytes}/(1+$this_stats->{done_bytes})));
276			$ll->{up}     = sprintf("%4.1f", $this_stats->{speed_upload}/1024);
277			$ll->{down}   = sprintf("%4.1f", $this_stats->{speed_download}/1024);
278			$ll->{eta}    = $self->{super}->Tools->SecondsToHuman($self->{super}->Tools->GetETA($key));
279			$ll->{note}   = join(' ',@xmsg);
280			$ll->{_color} = $xcolor;
281
282			my @this = (undef, map({$ll->{$_}} @order));
283			push(@a, [$xcolor,\@this]);
284		}
285	}
286
287
288
289
290	$a[0] = [1, sprintf(" *** Upload: %6.2f KiB/s | Download: %6.2f KiB/s | Peers: %3d/%3d",
291	                     ($self->{super}->Network->GetStats->{'sent'}/1024),
292	                     ($self->{super}->Network->GetStats->{'recv'}/1024),
293	                      $active_peers, $total_peers) ];
294
295
296	return {MSG=>\@a, SCRAP=>[] };
297}
298
299##########################################################################
300# Send out a notification
301sub _Command_Notify {
302	my($self, @args) = @_;
303	my $string = join(' ', @args);
304	$self->{super}->Admin->SendNotify($string);
305	return {MSG=>[ [ 1, 'notification sent'] ], SCRAP=>[] };
306}
307
308##########################################################################
309# Receive a notification (Called via Admin)
310sub _Receive_Notify {
311	my($self, $string) = @_;
312	my $numi   = ++$self->{notifyi};
313	my $numnot = push(@{$self->{notifyq}}, {id=>$numi,msg=>$string});
314	shift(@{$self->{notifyq}}) if $numnot > NOTIFY_BUFF;
315	$self->debug("Notification with ID $numi received ($numnot notifications buffered)");
316}
317
318
319##########################################################################
320# Own runner command
321sub run {
322	my($self,$NOW) = @_;
323
324	foreach my $csock (keys(%{$self->{sockbuffs}})) {
325		my $tsb = $self->{sockbuffs}->{$csock};
326
327		if(defined($tsb->{repeat}) && ! $self->{super}->Network->GetQueueLen($tsb->{socket})) {
328			$self->_Network_Data($tsb->{socket}, \$tsb->{repeat});
329		}
330
331		next if $tsb->{lastnotify} == $self->{notifyi}; # Does not need notification
332		foreach my $notify (@{$self->{notifyq}}) {
333			next if $notify->{id} <= $tsb->{lastnotify};
334			$tsb->{lastnotify} = $notify->{id};
335			if($tsb->{auth}) {
336				my $cbuff = $tsb->{p}.$tsb->{cbuff};
337
338				$self->{super}->Network->WriteDataNow($tsb->{socket}, ANSI_ESC."2K".ANSI_ESC."E");
339				$self->{super}->Network->WriteDataNow($tsb->{socket}, Alert(">".localtime()." [Notification]: $notify->{msg}")."\r\n$cbuff");
340			}
341		}
342	}
343	return 2;
344}
345
346
347##########################################################################
348# Accept new incoming connection
349sub _Network_Accept {
350	my($self,$sock) = @_;
351	$self->info("New incoming connection from ".$sock->peerhost);
352	$self->panic("Duplicate sockid?!") if defined($self->{sockbuffs}->{$sock});
353
354	# DO = 253 ; DO_NOT = 254 ; WILL = 251 ; WILL NOT 252
355	my $initcode =  chr(0xff).chr(251).chr(1).chr(0xff).chr(251).chr(3); # WILL echo + sup-go-ahead
356	   $initcode .= chr(0xff).chr(253).chr(31);                          # DO report window size
357
358	$self->{sockbuffs}->{$sock} = { cbuff => '', curpos=>0, history => [], h => 0, lastnotify => $self->{notifyi}, p => PROMPT, echo => 1,
359	                                socket => $sock, repeat => undef, iac=>0, iac_args=>'', multicmd=>0, terminal=>{w=>80,h=>25},
360	                                auth => $self->{super}->Admin->AuthenticateUser(User=>'', Pass=>''), auth_user=>undef };
361
362	$self->{sockbuffs}->{$sock}->{p} = 'Login: ' unless $self->{sockbuffs}->{$sock}->{auth};
363
364	my $motd     = "# Welcome to ".Green('Bitflu')."\r\n".$self->{sockbuffs}->{$sock}->{p};
365	$self->{super}->Network->WriteDataNow($sock, $initcode.$motd);
366}
367
368##########################################################################
369# Read data from network
370sub _Network_Data {
371	my($self,$sock,$buffref) = @_;
372
373	my $new_data = ${$buffref};
374	my $sb       = $self->{sockbuffs}->{$sock};
375	my @exe      = ();
376
377	foreach my $c (split(//,$new_data)) {
378		my $nc = ord($c);
379
380		if($nc == 0xFF) {
381			$sb->{iac} = 0xFF; # InterpretAsCommand
382		}
383		elsif($sb->{iac}) {
384			if($sb->{iac} == 0xff) {
385				# first char after IAC marker -> command opcode
386				if($nc == 240) {
387					$sb->{iac} = 1; # end of subneg
388					$self->UpdateTerminalSize($sb);
389				}
390				elsif($nc != 250) {
391					$sb->{iac} = 2; # normal command (no subneg)
392				}
393
394				$sb->{iac_args} = $c;
395			}
396			else {
397				$sb->{iac_args} .= $c;
398			}
399			$sb->{iac}--;
400		}
401		elsif($sb->{multicmd}) {
402			$sb->{multicmd}--;
403			next if $sb->{multicmd}; # walk all commands
404
405			if ($nc == KEY_LEFT) {
406				push(@exe, ['<',""]);
407			}
408			elsif($nc == KEY_RIGHT) {
409				push(@exe, ['>',""]);
410			}
411			elsif($nc == KEY_C_LEFT) { # CTRL+<
412
413				my $new_pos = 0; # start at beginning if everything else fails
414				my $saw_nws = 0; # state of loop (sawNonWhiteSpace)
415
416				for(my $i=($sb->{curpos}-1);$i>=0;$i--) { # start one behind current curpos (-1 if at beginning -> loop will do nothing)
417					my $this_char = substr($sb->{cbuff},$i,1);
418					$saw_nws = 1 if $this_char ne ' ';
419					if($this_char eq ' ' && $saw_nws) {
420						$new_pos = $i+1; # move one char ahead (*  [F]OO*)
421						last;
422					}
423				}
424
425				my $diff = ($sb->{curpos}-$new_pos);
426				$self->panic if $diff < 0;
427				map( push(@exe, ['<','']), (1..($sb->{curpos}-$new_pos)) );
428			}
429			elsif($nc == KEY_C_RIGHT) { # CTRL+>
430				my $cb_len  = length($sb->{cbuff});
431				my $new_pos = $cb_len;
432				my $saw_nws = 0;
433
434				for(my $i=$sb->{curpos};$i<$cb_len;$i++) {
435					my $this_char = substr($sb->{cbuff},$i,1);
436					$saw_nws = 1 if $this_char ne ' ';
437					if($this_char eq ' ' && $saw_nws) {
438						$new_pos=$i;
439						last;
440					}
441				}
442
443				my $diff = ($new_pos-$sb->{curpos});
444				$self->panic if $diff < 0;
445				map( push(@exe, ['>','']), (1..($diff)) );
446			}
447			elsif($nc == KEY_UP) {
448				push(@exe, ['h', +1]);
449			}
450			elsif($nc == KEY_DOWN) {
451				push(@exe, ['h', -1]);
452			}
453
454		}
455		elsif($nc == 0x1b) { $sb->{multicmd} = 2;   }
456		elsif($nc == 0x00) { }
457		elsif($c eq "\n")  { }
458		elsif($nc == 127 or $nc == 126 or $nc == 8) {
459			# -> 'd'elete char (backspace)
460			push(@exe, ['d', 1]);
461		}
462		elsif($nc == KEY_CTRLA) {
463			map(push(@exe, ['<','']), (1..$sb->{curpos}));
464		}
465		elsif($nc == KEY_CTRLE) {
466			map(push(@exe, ['>','']), ( $sb->{curpos}..(length($sb->{cbuff})-1) ));
467		}
468		elsif($c eq "\r") {
469			# -> E'X'ecute
470			if($sb->{auth}) {
471				push(@exe, ['X',undef]);  # execute
472			}
473			else {
474				push(@exe, ['!', undef]); # pass to authentication
475			}
476		}
477		elsif($nc == KEY_TAB && $sb->{auth}) {
478			push(@exe, ['T','']);
479		}
480		elsif($nc == KEY_CTRLD) {
481			push(@exe, ['X','quit']);
482		}
483		elsif($nc == KEY_CTRLL) {
484			push(@exe, ['X', 'clear']);
485			push(@exe, ['a', $sb->{cbuff}]);
486		}
487		elsif($nc == KEY_CTRLC) {
488			push(@exe, ['C', '']);
489			push(@exe, ['R', undef]);
490		}
491		else {
492			# 'a'ppend normal char
493			push(@exe, ['a', $c]);
494		}
495	}
496
497	while(defined(my $ocode = shift(@exe))) {
498		my $tx = undef;
499		my $oc = $ocode->[0];
500
501		my $twidth        = $sb->{terminal}->{w};
502		my $visible_chars = ( length($sb->{p}) + length($sb->{cbuff}) );
503		my $visible_curpos= (length($sb->{p})+$sb->{curpos});
504		my $line_position = ( $visible_curpos % $twidth );
505		my $chars_left    = $twidth-$line_position;
506
507		if($oc eq '<' or $oc eq '>') {
508
509			if($oc eq '<' && $sb->{curpos} > 0) {
510				$sb->{curpos}--;
511				if($line_position == 0) { $tx = ANSI_ESC."1A".ANSI_ESC."${twidth}C"; }
512				else                    { $tx = ANSI_ESC."1D";                       }
513			}
514
515			if($oc eq '>' && length($sb->{cbuff}) > $sb->{curpos}) {
516				$sb->{curpos}++;
517				if($chars_left == 1) { $tx = "\r\n";        }
518				else                 { $tx = ANSI_ESC."1C"; }
519			}
520		}
521		elsif($oc eq 'a') { # append a character
522			# insert chars
523			my $apn_length = length($ocode->[1]);
524			substr($sb->{cbuff},$sb->{curpos},0,$ocode->[1]);
525			$sb->{curpos}  += $apn_length;
526
527			if($sb->{echo}) {
528				if($chars_left > 1 && $sb->{curpos} == length($sb->{cbuff})) {
529					# Avoid flickering and fix/workaround for an obscure aterm(?) bug
530					$tx .= $ocode->[1];
531				}
532				else {
533					# cursor not at end -> do it the hard way
534					my $xc_after_line = int( ($visible_chars+$apn_length-1) / $twidth );
535					my $xc_want_line  = int( ($visible_curpos+$apn_length) / $twidth  );
536					my $xc_line_pos   = ( ($visible_curpos+$apn_length) % $twidth    );
537					my $xc_line_diff  = $xc_after_line-$xc_want_line;
538
539					$tx .= ANSI_ESC."0J".substr($sb->{cbuff},$sb->{curpos}-$apn_length); # delete from cursor and append data
540					$tx .= " \r".ANSI_ESC."K"            if $chars_left == 1;            # warp curor
541					$tx .= ANSI_ESC."${xc_line_diff}A"   if $xc_line_diff > 0;           # move to correct line (>0 : diff will be -1 on pseudo-warp)
542					$tx .= "\r";
543					$tx .= ANSI_ESC."${xc_line_pos}C"    if $xc_line_pos;                # move to corret linepos
544				}
545
546			}
547		}
548		elsif($oc eq 'd') { # Delete a character
549			my $can_remove = ( $ocode->[1] > $sb->{curpos} ? $sb->{curpos} : $ocode->[1] );
550
551			if($can_remove && $sb->{echo}) {
552				$sb->{curpos} -= $can_remove;
553				substr($sb->{cbuff},$sb->{curpos},$can_remove,"");                   # Remove chars from buffer
554
555				my $xc_current_line = int( $visible_curpos / $twidth );              # Line of cursor
556				my $xc_new_line     = int( ($visible_curpos-$can_remove)/$twidth );  # new line of cursor (after removing X chars)
557				my $xc_new_lpos     = int( ($visible_curpos-$can_remove)%$twidth );  # new position on lline
558				my $xc_append       = substr($sb->{cbuff},$sb->{curpos});            # remaining data
559				my $xc_total_line   = int( ($visible_chars-$can_remove-1)/$twidth ); # total number of lines - cursor (1)
560				my $xc_total_diff   = $xc_total_line - $xc_new_line;                 # remaining lines (after cursor)
561
562				$tx  = "\r";                                                         # move to start of line
563				$tx .= ANSI_ESC."${xc_current_line}A"   if $xc_current_line;         # move to line with prompt
564				$tx .= ANSI_ESC."${xc_new_line}B"       if $xc_new_line;             # move cursor to new line
565				$tx .= ANSI_ESC."${xc_new_lpos}C"       if $xc_new_lpos;             # move cursor to new position
566				$tx .= ANSI_ESC."0J".$xc_append."\r";                                # remove from cursor + append remaining data
567				$tx .= ANSI_ESC."${xc_new_lpos}C"       if $xc_new_lpos;             # fix line position (unchanged)
568				$tx .= ANSI_ESC."${xc_total_diff}A"     if $xc_total_diff;           # go up X lines
569			}
570		}
571		elsif($oc eq 'r') {
572			unshift(@exe, ['a', $ocode->[1]]);
573			unshift(@exe, ['d', length($sb->{cbuff})]);
574			$sb->{curpos} = length($sb->{cbuff});
575		}
576		elsif($oc eq 'h') {
577			my $hindx = $sb->{h} + $ocode->[1];
578			if($hindx >= 0 && $hindx < int(@{$sb->{history}})) {
579				$sb->{history}->[$sb->{h}] = $sb->{cbuff};
580				$sb->{h} = $hindx;
581				unshift(@exe, ['r', $sb->{history}->[$sb->{h}]]);
582			}
583		}
584		elsif($oc eq 'X') {
585			my $cmdout = $self->Xexecute($sock, (defined($ocode->[1]) ? $ocode->[1] : $sb->{cbuff}));
586			if(!defined($cmdout)) {
587				return undef; # quit;
588			}
589			# Make it an option "ignoredups"?
590			my $prev = $sb->{history}->[1];
591			if(defined $prev && $sb->{cbuff} eq $prev) { }
592			elsif(length($cmdout) && length($sb->{cbuff})) {
593				splice(@{$sb->{history}}, 0, 1, '', $sb->{cbuff});
594				pop(@{$sb->{history}}) if int(@{$sb->{history}}) > $self->{super}->Configuration->GetValue('telnet_maxhist');
595			}
596			unshift(@exe, ['C',$cmdout]);
597		}
598		elsif($oc eq '!') { # -> login user
599			if(length($sb->{auth_user}) == 0) {
600				$sb->{auth_user} = ($sb->{cbuff} || "NULL");
601				$sb->{echo}      = 0;
602				$sb->{p} = "Password: ";
603			}
604			else {
605				if( $self->{super}->Admin->AuthenticateUser(User=>$sb->{auth_user}, Pass=>$sb->{cbuff}) ) {
606					$sb->{echo} = $sb->{auth} = 1;
607					$sb->{p}    = $sb->{auth_user}.'@'.PROMPT;
608					$self->info("Telnet login from user $sb->{auth_user} completed");
609				}
610				else {
611					$self->info("Telnet login from user $sb->{auth_user} failed!");
612					unshift(@exe, ['X', 'quit']);
613					$sb->{p} = "Authentication failed, goodbye!\r\n\r\n"; # printed by the 'C' command below
614				}
615			}
616			unshift(@exe, ['C', '']); # get a new line with a fresh prompt
617		}
618		elsif($oc eq 'C') {
619			$sb->{h} = 0;
620			$sb->{cbuff}  = '';
621			$sb->{curpos} = 0;
622			$tx = "\r\n".$ocode->[1].$sb->{p};
623		}
624		elsif($oc eq 'R') { # Re-Set Repeat code
625			$sb->{repeat} = $ocode->[1];
626		}
627		elsif($oc eq 'T') {
628			my $tabref = $self->TabCompleter($sb->{cbuff});
629			if(defined($tabref->{append})) {
630				unshift(@exe, ['a', $tabref->{append}]); # append suggested data
631			}
632			elsif(int(@{$tabref->{matchlist}}) > 1) { # multiple suggestions -> print them, hit CTRL+c and restore buffer
633				unshift(@exe, ['r', "# ".join(" ",@{$tabref->{matchlist}})], ['C',''], ['a', $sb->{cbuff}]);
634			}
635		}
636		else {
637			$self->panic("Unknown telnet opcode '$oc'");
638		}
639
640		$self->{super}->Network->WriteDataNow($sock, $tx) if defined($tx);
641	}
642
643}
644
645sub UpdateTerminalSize {
646	my($self,$sb) = @_;
647
648	my $arg = $sb->{iac_args};
649	if( length($arg) == 6 && $arg =~ /^\xfa\x1f(..)(..)/ ) {
650		$sb->{terminal}->{w} = (unpack("n",$1) || 1);
651		$sb->{terminal}->{h} = (unpack("n",$2) || 1);
652	}
653}
654
655##########################################################################
656# Simple tab completition
657sub TabCompleter {
658	my($self,$inbuff) = @_;
659
660	my $result     = { append => undef, matchlist => [] };
661	my($cmd_part)  = $inbuff =~ /^(\S+)$/;
662	my($sha_part)  = $inbuff =~ / ([_0-9A-Za-z-]*)$/;
663
664	my @searchlist = ();
665	my @hitlist    = ();
666	my $searchstng = undef;
667
668	if(defined($cmd_part)) {
669		@searchlist = $self->{super}->Admin->GetCompletion('cmd');
670		$searchstng = $cmd_part;
671	}
672	elsif(defined($sha_part)) {
673		@searchlist = $self->{super}->Admin->GetCompletion('arg1');
674		$searchstng = $sha_part;
675	}
676
677	if(int(@searchlist)) {
678		foreach my $t (@searchlist) {
679			if($t =~ /^\Q$searchstng\E(.*)$/) {
680				push(@hitlist, $t);
681			}
682		}
683
684		if(int(@hitlist) == 1) { # just a single hit
685			$result->{append} = substr($hitlist[0],length($searchstng))." ";
686		}
687		elsif(int(@hitlist)) {
688			my $bestmatch = $self->FindBestMatch(@hitlist);
689
690			if($bestmatch eq $searchstng) { # no 'better' matches -> set matchlist
691				$result->{matchlist} = \@hitlist;
692			}
693			else { # possible part-list
694				$result->{append} = substr($bestmatch,length($searchstng));
695			}
696		}
697	}
698	return $result;
699}
700
701
702##########################################################################
703# Returns a common wordprefix..
704sub FindBestMatch {
705	my($self, @hitlist) =@_;
706
707	my $match = shift(@hitlist);
708
709	foreach my $word (@hitlist) {
710		my $i = 0;
711		while(++$i && $i<=length($word) && $i<=length($match)) {
712			if(substr($word,0,$i) ne substr($match,0,$i)) {
713				last;
714			}
715		}
716		$match = substr($word,0,$i-1); # $i is always > 0
717	}
718	return $match;
719}
720
721
722sub Xexecute {
723	my($self, $sock, $cmdstring) = @_;
724
725	my @xout = ();
726	my $sb   = $self->{sockbuffs}->{$sock};
727
728	foreach my $cmdlet (_deToken($cmdstring)) {
729		my $type            = $cmdlet->{type};
730		my ($command,@args) = @{$cmdlet->{array}};
731
732
733		if($command eq 'repeat' && int(@args)) {
734			my (undef,$rcmd) = $cmdstring =~ /(^|;)\s*repeat (.+)/;
735			if(length($rcmd)) {
736				$sb->{repeat} = $rcmd." # HIT CTRL+C TO STOP\r\n";
737				push(@xout, Green("Executing '$rcmd' each second, hit CTRL+C to stop\r\n"));
738				last;
739			}
740		}
741
742		if($type eq "pipe") {
743			if($command eq "grep") {
744				my $workat = (pop(@xout) || '');
745				my $filter = ($args[0]   || '');
746				my $result = '';
747				my $match  = 1;
748
749				if($filter eq '-v') {
750					$match  = 0;
751					$filter = ($args[1] || '');
752				}
753
754				foreach my $line (split(/\n/,$workat)) {
755					if( ($line =~ /\Q$filter\E/gi) == $match) {
756						$result .= $line."\n";
757					}
758				}
759				if(length($result) > 0) {
760					push(@xout,$result);
761				}
762				else {
763					push(@xout, "\00");
764				}
765			}
766			elsif($command eq "sort") {
767				my $workat = (pop(@xout) || '');
768				my $mode   = ($args[0]   || '');
769
770				if($mode eq '-r') { $mode = sub { $a cmp $b } }
771				else              { $mode = sub { $b cmp $a } }
772				push(@xout, join("\n", sort( {&$mode} split(/\n/,$workat)), "\00"));
773			}
774			elsif($command eq "head" or $command eq "tail") {
775				my $workat   = (pop(@xout) || '');
776				my @cmd_buff = (split(/\n/,$workat));
777				my ($limit)  = ($args[0]||'') =~ /^-(\d+)/;
778				$limit     ||= 10; # 10 is the default
779				$limit       = int(@cmd_buff) if int(@cmd_buff) < $limit;
780
781				if($command eq "head") {
782					@cmd_buff = splice(@cmd_buff,0,$limit);
783				}
784				else {
785					@cmd_buff = splice(@cmd_buff,-1*$limit);
786				}
787
788				push(@xout, join("\n", (@cmd_buff,"\00")));
789			}
790			else {
791				push(@xout, Red("Unknown pipe command '$command'\r\n"));
792			}
793		}
794		elsif($command =~ /^(q|quit|exit|logout)$/) {
795			$self->_Network_Close($sock);
796			$self->{super}->Network->RemoveSocket($self,$sock);
797			return undef;
798		}
799		else {
800			my $exe  = $self->{super}->Admin->ExecuteCommand($command,@args);
801			my $buff = '';
802			my @msg  = @{$exe->{MSG}};
803			my $spstr= $self->_GetSprintfLayout(\@msg,$sb->{terminal}->{w}); # returns '%s' in the worst case
804
805
806			foreach my $alin (@msg) {
807				my $cc = ($alin->[0] or 0);
808				my $cv = $alin->[1];
809
810				# array mode: first item specifies the variable-width row
811				# the rest is just arguments
812				$cv = sprintf($spstr, splice(@$cv,1)) if ref($cv) eq 'ARRAY';
813
814				   if($cc == 1)         { $buff .= Green($cv)  }
815				elsif($cc == 2)         { $buff .= Red($cv)    }
816				elsif($cc == 3)         { $buff .= Yellow($cv) }
817				elsif($cc == 4)         { $buff .= Cyan($cv)   }
818				elsif($cc == 5)         { $buff .= Blue($cv)   }
819				else                    { $buff .= $cv;        }
820				$buff .= "\r\n";
821
822				if($cc == 0xff)         { $buff = Clear($cv)   } # Special opcode: Clear the screen
823			}
824			push(@xout, $buff);
825		}
826	}
827
828	return join("",@xout);
829}
830
831##########################################################################
832# Parses $msg and creates a sprintf() string
833sub _GetSprintfLayout {
834	my($self,$msg, $twidth) = @_;
835
836	my @rows = ();    # row-width
837	my $xstr = '%s';  # our sprintf string - this is a fallback
838	my $vrow = undef; # variable-sized row
839	my $mlen = 4;     # minimum length of vrow
840	my $rsep = '?';
841
842	foreach my $alin (@$msg) {
843		next if ref($alin->[1]) ne 'ARRAY'; # plain string -> no row layout
844
845		# element 0 should be undef or a hashref with {vrow=>VARIABLE_ROW, rsep=>CHAR}
846		my $vdef = $alin->[1]->[0];
847		if(defined($vdef) && !defined($vrow)) {
848			($vrow,$rsep) = ($vdef->{vrow}, $vdef->{rsep});
849		}
850
851		for(my $i=1; $i<int(@{$alin->[1]});$i++) {
852			my $l = length($alin->[1]->[$i]);
853			$rows[$i-1] = $l if ($rows[$i-1] || 0) <= $l;
854		}
855	}
856
857	if(int(@rows)) { # -> we got a row layout - prepare special sprintf() string
858		for(0..1) {
859			$xstr = join($rsep, map({"%-${_}.${_}s"} @rows));
860			my $spare = $twidth - length(sprintf($xstr,@rows));
861			last if $spare >= 0; # was already ok or fixup was good
862			$rows[$vrow] += $spare;
863			$rows[$vrow] = $mlen if $rows[$vrow] < $mlen;
864		}
865	}
866
867	#$self->info("str=$xstr, vrow=$vrow, twidth=$twidth");
868	return $xstr;
869}
870
871##########################################################################
872# Close down TCP connection
873sub _Network_Close {
874	my($self,$sock) =  @_;
875	$self->info("Closing connection with ".$sock->peerhost);
876	delete($self->{sockbuffs}->{$sock});
877}
878
879##########################################################################
880# Parse tokens
881
882sub _deToken {
883	my($line) = @_;
884	my @parts    = ();
885	my @commands = ();
886	my $type     = 'cmd';
887
888	my $in_apostrophe = 0;
889	my $in_escape     = 0;
890	my $buffer        = undef;
891	$line            .= ";"; # Trigger a flush
892
893	for(my $i=0; $i<length($line); $i++) {
894		my $char = substr($line,$i,1);
895		if($in_escape) {
896			$buffer .= $char;
897			$in_escape = 0;
898		}
899		elsif($char eq "\\") {
900			$in_escape = 1;
901		}
902		elsif($in_apostrophe) {
903			if($char eq '"') { $in_apostrophe = 0; }
904			else             { $buffer .= $char;   }
905		}
906		else {
907			if($char eq '"') {
908				$in_apostrophe = 1;
909				$buffer .= '';
910			}
911			elsif($char =~ /\s|;|\|/) {
912				push(@parts,$buffer) if defined($buffer);
913				$buffer = undef;
914			}
915			else {
916				$buffer .= $char;
917			}
918			#####
919			if($char =~ /;|\|/) {
920				my @xcopy = @parts;
921				push(@commands,{type=>$type, array=>\@xcopy}) if int(@parts);
922				@parts = ();
923				$type  = ($char eq ';' ? 'cmd' : 'pipe');
924			}
925		}
926	}
927
928	return @commands;
929}
930
931
932
933sub Green {
934	my($s) = @_;
935	my ($string,$end) = AnsiCure($s);
936	$s = ANSI_ESC.ANSI_BOLD.ANSI_GREEN.$string.ANSI_ESC.ANSI_RSET;
937	$s .= $end if defined($end);
938	return $s;
939}
940
941sub Cyan {
942	my($s) = @_;
943	my ($string,$end) = AnsiCure($s);
944	$s = ANSI_ESC.ANSI_BOLD.ANSI_CYAN.$string.ANSI_ESC.ANSI_RSET;
945	$s .= $end if defined($end);
946	return $s;
947}
948
949sub Yellow {
950	my($s) = @_;
951	my ($string,$end) = AnsiCure($s);
952	$s = ANSI_ESC.ANSI_BOLD.ANSI_YELLOW.BgBlack($string).ANSI_ESC.ANSI_RSET;
953	$s .= $end if defined($end);
954	return $s;
955}
956
957sub Blue {
958	my($s) = @_;
959	my ($string,$end) = AnsiCure($s);
960	$s = ANSI_ESC.ANSI_BOLD.ANSI_BLUE.BgBlack($string).ANSI_ESC.ANSI_RSET;
961	$s .= $end if defined($end);
962	return $s;
963}
964
965sub Red {
966	my($s) = @_;
967	my ($string,$end) = AnsiCure($s);
968	$s = ANSI_ESC.ANSI_BOLD.ANSI_RED.$string.ANSI_ESC.ANSI_RSET;
969	$s .= $end if defined($end);
970	return $s;
971}
972
973sub Alert {
974	my($s) = @_;
975	my ($string,$end) = AnsiCure($s);
976	$s = ANSI_ESC.ANSI_BOLD.ANSI_WHITE.BgBlue($s).ANSI_ESC.ANSI_RSET;
977	$s .= $end if defined($end);
978	return $s;
979}
980
981sub Clear {
982	my($s) = @_;
983	return ANSI_ESC.'H'.ANSI_ESC.'2J'.$s;
984}
985
986sub BgBlue {
987	my($s) = @_;
988	$s = ANSI_ESC."44m".$s;
989	return $s;
990}
991
992sub BgBlack {
993	my($s) = @_;
994	$s = ANSI_ESC."40m".$s;
995	return $s;
996}
997
998sub AnsiCure {
999	my($s) = @_;
1000	my $badend = chop($s);
1001	if($badend ne "\n") { $s .= $badend ; $badend = undef }
1002	return($s,$badend);
1003}
1004
1005sub debug { my($self, $msg) = @_; $self->{super}->debug("Telnet  : ".$msg); }
1006sub info  { my($self, $msg) = @_; $self->{super}->info("Telnet  : ".$msg);  }
1007sub panic { my($self, $msg) = @_; $self->{super}->panic("Telnet  : ".$msg); }
1008sub stop { my($self, $msg) = @_; $self->{super}->stop("Telnet  : ".$msg); }
1009
1010
1011
10121;
1013