Commit | Line | Data |
---|---|---|
34e49164 C |
1 | (* File: ANSITerminal.ml |
2 | Allow colors, cursor movements, erasing,... under Unix and DOS shells. | |
3 | ********************************************************************* | |
4 | ||
5 | Copyright 2004 by Troestler Christophe | |
6 | Christophe.Troestler(at)umh.ac.be | |
7 | ||
8 | This library is free software; you can redistribute it and/or | |
9 | modify it under the terms of the GNU Lesser General Public License | |
10 | version 2.1 as published by the Free Software Foundation, with the | |
11 | special exception on linking described in file LICENSE. | |
12 | ||
13 | This library is distributed in the hope that it will be useful, but | |
14 | WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file | |
16 | LICENSE for more details. | |
17 | *) | |
18 | (** See the file ctlseqs.html (unix) | |
19 | and (for DOS) http://www.ka.net/jmenees/Dos/Ansi.htm | |
20 | *) | |
21 | ||
22 | ||
23 | open Printf | |
24 | ||
25 | (* Erasing *) | |
26 | ||
27 | type loc = Above | Below | Screen | |
28 | ||
29 | let erase = function | |
30 | | Above -> print_string "\027[1J" | |
31 | | Below -> print_string "\027[0J" | |
32 | | Screen -> print_string "\027[2J" | |
33 | ||
34 | ||
35 | (* Cursor *) | |
36 | ||
37 | let set_cursor x y = | |
38 | if x <= 0 then (if y > 0 then printf "\027[%id" y) | |
39 | else (* x > 0 *) if y <= 0 then printf "\027[%iG" x | |
40 | else printf "\027[%i;%iH" y x | |
41 | ||
42 | let move_cursor x y = | |
43 | if x > 0 then printf "\027[%iC" x | |
44 | else if x < 0 then printf "\027[%iD" (-x); | |
45 | if y > 0 then printf "\027[%iB" y | |
46 | else if y < 0 then printf "\027[%iA" (-y) | |
47 | ||
48 | let save_cursor () = print_string "\027[s" | |
49 | let restore_cursor () = print_string "\027[u" | |
50 | ||
51 | (* Scrolling *) | |
52 | ||
53 | let scroll lines = | |
54 | if lines > 0 then printf "\027[%iS" lines | |
55 | else if lines < 0 then printf "\027[%iT" (- lines) | |
56 | ||
57 | (* Colors *) | |
58 | ||
59 | let autoreset = ref true | |
60 | ||
61 | let set_autoreset b = autoreset := b | |
62 | ||
63 | ||
64 | type color = | |
65 | Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default | |
66 | ||
67 | type style = | |
68 | | Reset | Bold | Underlined | Blink | Inverse | Hidden | |
69 | | Foreground of color | |
70 | | Background of color | |
71 | ||
72 | let black = Foreground Black | |
73 | let red = Foreground Red | |
74 | let green = Foreground Green | |
75 | let yellow = Foreground Yellow | |
76 | let blue = Foreground Blue | |
77 | let magenta = Foreground Magenta | |
78 | let cyan = Foreground Cyan | |
79 | let white = Foreground White | |
80 | let default = Foreground Default | |
81 | ||
82 | let on_black = Background Black | |
83 | let on_red = Background Red | |
84 | let on_green = Background Green | |
85 | let on_yellow = Background Yellow | |
86 | let on_blue = Background Blue | |
87 | let on_magenta = Background Magenta | |
88 | let on_cyan = Background Cyan | |
89 | let on_white = Background White | |
90 | let on_default = Background Default | |
91 | ||
92 | let style_to_string = function | |
93 | | Reset -> "0" | |
94 | | Bold -> "1" | |
95 | | Underlined -> "4" | |
96 | | Blink -> "5" | |
97 | | Inverse -> "7" | |
98 | | Hidden -> "8" | |
99 | | Foreground Black -> "30" | |
100 | | Foreground Red -> "31" | |
101 | | Foreground Green -> "32" | |
102 | | Foreground Yellow -> "33" | |
103 | | Foreground Blue -> "34" | |
104 | | Foreground Magenta -> "35" | |
105 | | Foreground Cyan -> "36" | |
106 | | Foreground White -> "37" | |
107 | | Foreground Default -> "39" | |
108 | | Background Black -> "40" | |
109 | | Background Red -> "41" | |
110 | | Background Green -> "42" | |
111 | | Background Yellow -> "43" | |
112 | | Background Blue -> "44" | |
113 | | Background Magenta -> "45" | |
114 | | Background Cyan -> "46" | |
115 | | Background White -> "47" | |
116 | | Background Default -> "49" | |
117 | ||
118 | ||
119 | let print_string style txt = | |
120 | print_string "\027["; | |
121 | let s = String.concat ";" (List.map style_to_string style) in | |
122 | print_string s; | |
123 | print_string "m"; | |
124 | print_string txt; | |
125 | if !autoreset then print_string "\027[0m" | |
126 | ||
127 | ||
128 | let printf style = kprintf (print_string style) | |
129 | ||
130 | ||
131 | ||
132 | (* On DOS & windows, to enable the ANSI sequences, ANSI.SYS should be | |
133 | loaded in C:\CONFIG.SYS with a line of the type | |
134 | ||
135 | DEVICE = C:\DOS\ANSI.SYS | |
136 | DEVICEHIGH=C:\WINDOWS\COMMAND\ANSI.SYS | |
137 | ||
138 | This routine checks whether the line is present and, if not, it | |
139 | inserts it and tells the user to reboot. | |
140 | ||
141 | On WINNT, one will create a ANSI.NT in the user dir and a | |
142 | command.com link on the desktop (with Configfilename = our ANSI.NT) | |
143 | and tell the user to use it. | |
144 | ||
145 | REM: that does NOT work under winxp because OCaml programs are not | |
146 | considered to run in DOS mode only... | |
147 | ||
148 | http://support.microsoft.com/default.aspx?scid=kb;en-us;816179 | |
149 | http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/console_functions.asp | |
150 | *) | |
151 | ||
152 | ||
153 | (* let is_readable file = *) | |
154 | (* try close_in(open_in file); true *) | |
155 | (* with Sys_error _ -> false *) | |
156 | ||
157 | (* let config_sys = "C:\\CONFIG.SYS" *) | |
158 | (* exception OK *) | |
159 | ||
160 | (* let win9x () = *) | |
161 | (* (\* Locate ANSI.SYS *\) *) | |
162 | (* let ansi_sys = List.find is_readable [ *) | |
163 | (* "C:\\DOS\\ANSI.SYS"; *) | |
164 | (* "C:\\WINDOWS\\COMMAND\\ANSI.SYS"; ] in *) | |
165 | (* (\* Parse CONFIG.SYS to see wether it has the right line *\) *) | |
166 | (* try *) | |
167 | (* let re = Str.regexp_case_fold *) | |
168 | (* ("^DEVICE\\(HIGH\\)?[ \t]*=[ \t]*" ^ ansi_sys ^ "[ \t]*$") in *) | |
169 | (* let fh = open_in config_sys in *) | |
170 | (* begin try *) | |
171 | (* while true do *) | |
172 | (* if Str.string_match re (input_line fh) 0 then raise OK *) | |
173 | (* done *) | |
174 | (* with *) | |
175 | (* | End_of_file -> *) | |
176 | (* (\* Correct line not found: add it *\) *) | |
177 | (* close_in fh; *) | |
178 | (* raise(Sys_error "win9x") *) | |
179 | (* | OK -> close_in fh (\* Correct line found, keep going *\) *) | |
180 | (* end *) | |
181 | (* with Sys_error _ -> *) | |
182 | (* (\* config_sys not does not exists or does not contain the right line. *\) *) | |
183 | (* let fh = open_out_gen [Open_wronly; Open_append; Open_creat; Open_text] *) | |
184 | (* 0x777 config_sys in *) | |
185 | (* output_string fh ("DEVICEHIGH=" ^ ansi_sys ^ "\n"); *) | |
186 | (* close_out fh; *) | |
187 | (* prerr_endline "Please restart your computer and rerun the program."; *) | |
188 | (* exit 1 *) | |
189 | ||
190 | ||
191 | ||
192 | (* let winnt home = *) | |
193 | (* (\* Locate ANSI.SYS *\) *) | |
194 | (* let system = *) | |
195 | (* try Sys.getenv "SystemRoot" *) | |
196 | (* with Not_found -> "C:\\WINDOWS" in *) | |
197 | (* let ansi_sys = *) | |
198 | (* List.find is_readable (List.map (fun s -> Filename.concat system s) *) | |
199 | (* [ "SYSTEM32\\ANSI.SYS"; ]) in *) | |
200 | (* (\* Create an ANSI.SYS file in the user dir *\) *) | |
201 | (* let ansi_nt = Filename.concat home "ANSI.NT" in *) | |
202 | (* let fh = open_out ansi_nt in *) | |
203 | (* output_string fh "dosonly\ndevice="; *) | |
204 | (* output_string fh ansi_sys; *) | |
205 | (* output_string fh "\ndevice=%SystemRoot%\\system32\\himem.sys *) | |
206 | (* files=40 *) | |
207 | (* dos=high, umb *) | |
208 | (* " ; *) | |
209 | (* close_out fh; *) | |
210 | (* (\* Make a command.com link on the desktop *\) *) | |
211 | (* let fh = open_out (Filename.concat home "command.lnk") in *) | |
212 | (* close_out fh *) | |
213 | ||
214 | ||
215 | (* let () = *) | |
216 | (* if Sys.os_type = "Win32" then begin *) | |
217 | (* try winnt(Sys.getenv "USERPROFILE") (\* WinNT, Win2000, WinXP *\) *) | |
218 | (* with Not_found -> win9x() (\* Win9x *\) *) | |
219 | (* end *) |