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