src/utils/net/terminal.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Printf2
  21
  22 (*
  23 type command =
  24   | Message of string
  25   | Command of string
  26
  27
  28 module Vt100 = struct
  29
  30 (* permet de manipuler le terminal *)
  31
  32     let width = ref 80
  33     let  height = ref 24
  34
  35   let cx = ref 0
  36   let cy = ref 0
  37
  38   let in_update = ref false
  39
  40   let gotoxy x y =
  41     if not !in_update then begin
  42       cx := x;
  43       cy := y
  44     end;
  45     Printf2.lprintf "\027[%d;%dH" (y+1) (x+1)
  46
  47   let stdvid () = print_string "\027[m" (* "]" *);;
  48
  49   let revvid () = print_string "\027[7m"
  50
  51   let clrscr () = print_string "\027[2J"
  52
  53 let vtflush () = flush stdout
  54
  55 (* begin_update / end_update :                               *)
  56 (* Sert uniquement à sauvegarder la position du curseur.     *)
  57 (* N'assure pas d'exclusion mutuelle pour l'accès à l'écran. *)
  58
  59 let begin_update () = in_update := true
  60 let end_update () = gotoxy !cx !cy; in_update := false
  61
  62 let beep () = print_char '\007'; flush stdout
  63
  64 end
  65
  66 open Vt100
  67 open Printf
  68
  69   type etat = {
  70       mutable durty_line : bool ; (* la ligne courante est-elle a jour ? *)
  71       mutable durty_info : bool ; (* le bandeau d'info est-il a jour ? *)
  72       mutable ligne : string ;    (* ligne courante *)
  73       mutable pos   : int ;       (* position dans cette ligne *)
  74       mutable trailer : string list;
  75       mutable header : string list;
  76     }
  77
  78   (* initialisatino de l'etat *)
  79   let etat = { ligne = ""; pos = 0; trailer = [];
  80 header = [];
  81  durty_line = true ; durty_info = true }
  82
  83   (* ajoute les espaces a la fin de la chaine s pour atteindre la taille w *)
  84   let align w s =
  85     let l = String.length s in
  86     if l < w then s^String.make (w-l) ' ' else String.sub s 0 w
  87
  88   let prompt = ref "> "
  89   let off = ref (String.length !prompt)
  90
  91
  92 type control =
  93   | CHANGE_LINE of string * int
  94  (* Commande générique *)
  95   | COMMAND of string
  96  (* message en entree *)
  97   | MES_IN of string
  98  (* message recu d'un canal *)
  99   | MES_OUT of string (* canal * message *)
 100  (* message d'information (resultat d'une commande...) *)
 101   | INFO of string
 102
 103 let reader = ref (fun _ -> ())
 104 let set_reader f = reader := f
 105
 106   (* met a jour la ligne *)
 107   let change_line () =
 108     gotoxy 0 (!height - 1);
 109     print_string (!prompt^align (!width - !off) etat.ligne);
 110     gotoxy (!off + etat.pos) (!height - 1);
 111     flush stdout ;
 112     etat.durty_line <- false
 113
 114   (* meet a jour le bandeau d'info *)
 115   let change_info () =
 116     revvid ();
 117     let rec iter i list =
 118       match list with
 119         [] -> ()
 120       | line :: tail ->
 121          gotoxy 0 i;
 122          print_string (align !width line);
 123   iter (i+1) tail
 124     in
 125     iter 0 etat.header;
 126     let rec iter i list =
 127       match list with
 128         [] -> ()
 129       | line :: tail ->
 130          gotoxy 0 (!height - i - 1);
 131          print_string (align !width line);
 132   iter (i-1) tail
 133     in
 134     iter (List.length etat.trailer) etat.trailer;
 135     stdvid () ;
 136     etat.durty_info <- false
 137
 138   (* ajoute une ligne au-dessus du bandeau *)
 139   let print_line s =
 140     gotoxy 0 (!height - (List.length etat.trailer) -1) ;
 141     print_string (align !width s);
 142     gotoxy 0 (!height-1) ;
 143     print_newline ();
 144     etat.durty_line <- true ;
 145     etat.durty_info <- true
 146
 147
 148 let set_prompt p = prompt := p; off := String.length p
 149
 150 let set_header lines =
 151   etat.header <- lines;
 152   etat.durty_info <- true;
 153   change_info ()
 154
 155 let set_trailer lines =
 156   etat.trailer <- lines;
 157   etat.durty_info <- true;
 158   change_info ()
 159
 160
 161
 162
 163 module Output = struct
 164
 165
 166   (* recoit les commandes l'affichage, il y a un mutex pour qu'il
 167      n'y ait qu'une seule instance a la fois, c'est un mutex sur l'ecran *)
 168   let rec control c =
 169     let info m =  control (INFO m) in begin
 170       (match c with
 171       | CHANGE_LINE (s,i) ->
 172    etat.ligne <- s;
 173    etat.pos <- i;
 174    etat.durty_line <- true
 175  (* une commande est recue *)
 176       | COMMAND (cmd) -> !reader (Command cmd)
 177 (*
 178    let lexbuf = Lexing.from_string cmd in
 179    try
 180      (* on la parse *)
 181      match Parser.cmd Lexer.cmd lexbuf with
 182             | Help -> info ("ceci est l'aide")
 183      | Join chan -> begin
 184        try
 185   let canal = List.assoc chan !chanmap in
 186   etat.chan <- Some (chan, canal);
 187   info (sprintf "connecte au canal '%s'" chan);
 188   (* {| canal ALL } *)
 189        with Not_found -> (* pas encore de recepteur pour ce canal *)
 190   try (* on en cree un *)
 191     let serveur = nsrecord.get_loc chan in
 192     etat.chan <- Some (chan, create_channel chan serveur control) ;
 193     info (sprintf "connecte au canal '%s'" chan)
 194   with Not_found ->
 195     info (sprintf "canal '%s' inexistant" chan)
 196      end
 197      | Create chan -> begin
 198   let chan = String.sub cmd 7 (String.length cmd - 7) in
 199   try
 200     let _ = nsrecord.get_loc chan in
 201     info (sprintf "canal '%s' deja existant" chan)
 202       with Not_found ->
 203     let serveur = create_server chan in
 204     nsrecord.add_channel (chan,serveur);
 205     info (sprintf "canal '%s' cree" chan);
 206         control (COMMAND ("join "^chan)) (* on join le canal *)
 207      end
 208      | GetAll ->
 209   List.iter (fun s -> info s) (nsrecord.get_all_chan ())
 210    with Parsing.Parse_error ->
 211    info ("mauvaise commande, taper aide pour la "^
 212   "liste des commandes");
 213       end *)
 214         (* un message est recu depuis le clavier *)
 215       | MES_IN m ->
 216         !reader (Message m)
 217  (* un message est recu depuis le gestionnaire du canal *)
 218       | MES_OUT m -> (
 219      (* c'est bien le canal actif, on l'affiche *)
 220        print_line m
 221      (* sinon, rien *)
 222   )
 223  (* un message d'info a afficher *)
 224       | INFO m -> print_line ("$ "^m)
 225       );
 226       (* on met a jour ce qu'il faut *)
 227       if etat.durty_info then change_info ();
 228       if etat.durty_line then change_line ()
 229     end
 230
 231 end
 232
 233 let output c = Output.control c
 234
 235 let print m = output (MES_OUT m)
 236
 237 (* input *)
 238 module Input = struct
 239   open String
 240   type seq_state =
 241     | NORMAL
 242     | ESC
 243     | SQUARE
 244                                          | TILDE
 245
 246   type state = {
 247       mutable history : string list ; (* l'historique des commandes *)
 248       mutable curline : int ;         (* la ligne visible *)
 249       mutable nbline : int ;          (* le nombre de lignes en tout *)
 250       mutable line : string ;         (* la ligne courante *)
 251       mutable pos : int ;             (* la position courante sur cette ligne *)
 252       mutable seq : seq_state;        (* l'etat pour les sequences de caracteres *)
 253     }
 254
 255   (* initialisation de l'etat *)
 256   let s = { history = []; curline = 0; nbline = 0 ;
 257         line = ""; pos = 0; seq = NORMAL }
 258
 259
 260
 261   let init () =
 262   let sock = TcpBufferedSocket.create "stdin" Unix.stdin
 263     (fun _ _ -> ()) in
 264
 265     TcpBufferedSocket.set_reader sock (
 266        fun sock nr ->
 267     let change () = output (CHANGE_LINE (s.line,s.pos)) in
 268     (* on lit un paquet de touches au clavier *)
 269     let b = TcpBufferedSocket.buf sock in
 270     let buf = String.sub b.TcpBufferedSocket.buf b.TcpBufferedSocket.pos nr in
 271     TcpBufferedSocket.buf_used sock nr;
 272     (* on les traite *)
 273     for i = 0 to nr - 1 do
 274       let c = buf.[i] in
 275       match s.seq with
 276       | NORMAL ->
 277    begin match c with
 278    | '\n' ->
 279        let line = s.line in
 280        (* est-ce une commande (debut par /) *)
 281        if length line >= 2 && line.[0] = '/' && line.[1] <> '/' then
 282    output (COMMAND
 283       (sub (lowercase line) 1 (length line - 1)))
 284        else if line <> "" then
 285    output (MES_IN line);
 286        if line <> "" && ((s.nbline > 0 && List.hd s.history <> line)
 287          || s.nbline = 0)
 288        then begin
 289   (* on ajoute la ligne a l'historique si ce n'est pas la meme
 290      que la precedente et qu'elle n'est pas vide *)
 291   s.history <- (s.line :: s.history);
 292   s.nbline <- s.nbline + 1;
 293        end;
 294        (* reset *)
 295        s.curline <- 0;
 296        s.line <- "";
 297        s.pos <- 0;
 298 (*   | c -> print_string (Char.escaped c); flush stdout*)
 299        (* DEL *)
 300    | '\008' | '\127' when s.pos > 0 ->
 301        let l = length s.line in
 302        s.line <- sub s.line 0 (s.pos-1) ^ sub s.line s.pos (l-s.pos) ;
 303        s.pos <- s.pos - 1
 304       (* DEL ou EOF *)
 305    | '\008' | '\127' | '\004' -> ()
 306       (* HOME *)
 307    | '\001' -> s.pos <- 0
 308       (* END *)
 309    | '\005' -> s.pos <- String.length s.line
 310       (* debut d'une sequence *)
 311    | '\027' -> s.seq <- ESC
 312       (* on ajoute le caractere a la ligne la ou l'on est *)
 313    | c ->
 314        s.line <- sub s.line 0 s.pos ^ (make 1 c) ^
 315   sub s.line s.pos (length s.line - s.pos) ;
 316        s.pos <- s.pos + 1
 317    end;
 318    change ()
 319       | ESC ->
 320    begin match c with
 321    | '[' -> s.seq <- SQUARE
 322    | _ -> s.seq <- NORMAL
 323    end
 324       | SQUARE ->
 325 (*   gotoxy 1 1;
 326    printf "%d %d" s.curline s.nbline; *)
 327    begin match c with
 328      (* fleche droite *)
 329    | 'C' when s.pos < String.length s.line ->
 330        s.pos <- s.pos + 1;
 331        (* fleche gauche *)
 332    | 'D' when s.pos > 0 ->
 333        s.pos <- s.pos - 1;
 334        (* haut *)
 335    | 'A' when s.curline = 0 && s.line <> "" && s.nbline > 0
 336      && List.hd s.history <> s.line ->
 337        (* on doit ajouter la ligne courante et il y en a
 338    deja au moins une dans l'historique *)
 339        s.history <- s.line :: s.history;
 340        s.nbline <- s.nbline + 1;
 341        s.line <- List.nth s.history 1;
 342        s.curline <- 1 ;
 343        s.pos <- length s.line
 344    | 'A' when s.curline = 0 && s.line <> "" && s.nbline > 1 ->
 345        (* on ne doit pas ajouter la ligne courante car c'est la
 346    meme que la premiere ligne de l'historique et il y en a
 347    deja au moins une dans l'historique *)
 348        s.line <- List.nth s.history 1;
 349        s.curline <- 1 ;
 350        s.pos <- length s.line
 351    | 'A' when s.curline = 0 && s.nbline > 0 ->
 352        (* on ne doit pas ajouter la ligne courante *)
 353        s.line <- List.nth s.history 0;
 354        s.pos <- length s.line
 355    | 'A' when s.curline < s.nbline - 1 ->
 356        (* cas normal : on est en train de parcourir la liste *)
 357   s.curline <- s.curline + 1;
 358   s.line <- List.nth s.history s.curline;
 359        s.pos <- length s.line
 360    | 'A' when s.curline = s.nbline - 1 ->
 361        (* on arrive en bout de liste *)
 362        s.line <- List.nth s.history s.curline;
 363        s.pos <- length s.line
 364        (* bas *)
 365    | 'B' when s.curline > 0 ->
 366        (* on parcourt la liste dans l'autre sens *)
 367        s.curline <- s.curline - 1;
 368        s.line <- List.nth s.history s.curline;
 369        s.pos <- length s.line
 370    | 'B' (* curline = 0 *) ->
 371        s.line <- "";
 372        s.pos <- 0
 373     (* home *)
 374    | '1' | 'H' ->
 375        s.pos <- 0;
 376        if c = '1' then s.seq <- TILDE
 377     (* end *)
 378    | '4' | 'F' ->
 379        s.pos <- length s.line;
 380        if c = '4' then s.seq <- TILDE
 381     (* DELETE *)
 382    | '3' ->
 383        let l = length s.line in
 384        if s.pos < l then
 385   s.line <- sub s.line 0 s.pos ^
 386     sub s.line (s.pos+1) (l-s.pos-1) ;
 387        s.seq <- TILDE
 388    | _ -> ()
 389    end;
 390    if s.seq = SQUARE then s.seq <- NORMAL;
 391    change ()
 392  (* les sequences se terniment souvent pas un ~ qu'il faut faire
 393     disparaitre *)
 394       | TILDE ->
 395    s.seq <- NORMAL
 396     done)
 397
 398 end
 399
 400 let init () =
 401   begin
 402     try
 403       width := int_of_string (Sys.getenv "COLUMNS");
 404       height :=  int_of_string (Sys.getenv "LINES");
 405     with _ ->
 406       print_endline "$LINES/$COLUMNS not defined.";
 407       print_endline "try 'export LINES COLUMNS'"
 408   end;
 409
 410
 411   (* mise en place des paramettres du terminal *)
 412   let attr_save = Unix.tcgetattr Unix.stdin in
 413   let restore () = Unix.tcsetattr Unix.stdin Unix.TCSANOW attr_save in
 414   at_exit restore;
 415   let attr = Unix.tcgetattr Unix.stdin in
 416   attr.Unix.c_icanon <- false;
 417   attr.Unix.c_echo <- false;
 418  attr.Unix.c_vmin <- 1;
 419   Unix.tcsetattr Unix.stdin Unix.TCSANOW attr;
 420   Vt100.clrscr ();
 421   Input.init ()
 422
 423 let update () = change_info (); flush stdout
 424
 425 (*
 426 let _ =
 427   init ();
 428   set_reader (fun cmd ->
 429     match cmd with
 430       Message m -> print m
 431     | Command cmd -> print (sprintf "COMMAND %s" cmd)
 432   );
 433   set_trailer ["TRAILER"];
 434   set_header ["HEADER"];
 435   update ();
 436   BasicSocket.loop ()
 437 *)
 438
 439 *)
 440
 441 module ANSI = struct
 442
 443     let esc =  "\027" (* 033 *)
 444     let esc_CHAR = '\027'
 445
 446 (*  Puts everything back to normal *)
 447
 448     let ansi_NORMAL = esc ^ "[2;37;0m"
 449
 450     let ansi_CLRSCR =   esc ^ "[2J"
 451     let ansi_CLREOL =   esc ^ "[2K"
 452
 453 (*  Non-color based font changes *)
 454
 455     let ansi_BOLD   = esc ^ "[1m" (* Turn on bold mode *)
 456     let ansi_BLINK   = esc ^ "[5m"
 457 (* Initialize blink mode *)
 458     let ansi_UNDERLINE   = esc ^ "[4m"
 459 (* Initialize underscore mode *)
 460     let ansi_REVERSE  = esc ^ "[7m" (* Turns reverse video mode on *)
 461     let ansi_HIGH_REVERSE  = esc ^ "[1,7m" (* Hi intensity reverse video  *)
 462
 463 (*   Foreground Colors   *)
 464
 465     let ansi_BLACK  = esc ^ "[30m"
 466     let ansi_RED  = esc ^ "[31m"
 467     let ansi_GREEN  = esc ^ "[32m"
 468     let ansi_YELLOW  = esc ^ "[33m"
 469     let ansi_BLUE  = esc ^ "[34m"
 470     let ansi_MAGENTA  = esc ^ "[35m"
 471     let ansi_CYAN  = esc ^ "[36m"
 472     let ansi_WHITE  = esc ^ "[37m"
 473
 474 (*   Hi Intensity Foreground Colors   *)
 475
 476     let ansi_HIGH_RED   = esc ^ "[1;31m"
 477     let ansi_HIGH_GREEN  = esc ^ "[1;32m"
 478     let ansi_HIGH_YELLOW  = esc ^ "[1;33m"
 479     let ansi_HIGH_BLUE   = esc ^ "[1;34m"
 480     let ansi_HIGH_MAGENTA  = esc ^ "[1;35m"
 481     let ansi_HIGH_CYAN   = esc ^ "[1;36m"
 482     let ansi_HIGH_WHITE  = esc ^ "[1;37m"
 483
 484 (*  Background Colors *)
 485
 486     let ansi_BACKGROUND_BLACK  = esc ^ "[40m"
 487     let ansi_BACKGROUND_RED  = esc ^ "[41m"
 488     let ansi_BACKGROUND_GREEN  = esc ^ "[42m"
 489     let ansi_BACKGROUND_YELLOW  = esc ^ "[43m"
 490     let ansi_BACKGROUND_BLUE  = esc ^ "[44m"
 491     let ansi_BACKGROUND_MAGENTA = esc ^ "[45m"
 492     let ansi_BACKGROUND_CYAN  = esc ^ "[46m"
 493     let ansi_BACKGROUND_WHITE  = esc ^ "[47m"
 494
 495 (*  High Intensity Background Colors  *)
 496
 497     let ansi_HIGH_BACKGROUND_RED  = esc ^ "[41;1m"
 498     let ansi_HIGH_BACKGROUND_GREEN  = esc ^ "[42;1m"
 499     let ansi_HIGH_BACKGROUND_YELLOW  = esc ^ "[43;1m"
 500     let ansi_HIGH_BACKGROUND_BLUE  = esc ^ "[44;1m"
 501     let ansi_HIGH_BACKGROUND_MAGENTA  = esc ^ "[45;1m"
 502     let ansi_HIGH_BACKGROUND_CYAN  = esc ^ "[46;1m"
 503     let ansi_HIGH_BACKGROUND_WHITE  = esc ^ "[47;1m"
 504
 505
 506   end
 507
 508   (*
 509 external get_screen_size : Unix.file_descr -> bool = "ml_get_screen_size"
 510 external screen_width : unit -> int = "ml_screen_width"
 511 external screen_height : unit -> int = "ml_screen_height"
 512 *)
 513
 514 (* How do you get the size associated with a socket ? I have no book here,
 515 I think we have to associate a pseudo-tty with the socket, but I don't
 516 remember exactly... so, keep it simple. *)
 517
 518
 519 let gotoxy x y =  Printf.sprintf "\027[%d;%dH" (y+1) (x+1)