File: utility.ml

package info (click to toggle)
wyrd 1.4.6-4
  • links: PTS
  • area: main
  • in suites: buster, stretch
  • size: 1,820 kB
  • ctags: 1,969
  • sloc: ml: 11,059; sh: 5,531; ansic: 760; makefile: 304; python: 44
file content (387 lines) | stat: -rw-r--r-- 12,177 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
(*  Wyrd -- a curses-based front-end for Remind
 *  Copyright (C) 2005, 2006, 2007, 2008, 2010, 2011-2013 Paul Pelzl
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License, Version 2,
 *  as published by the Free Software Foundation.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *
 *  Bug reports can be entered at http://bugs.launchpad.net/wyrd .
 *  For anything else, feel free to contact Paul Pelzl at <pelzlpj@gmail.com>.
 *)

(* utility.ml
 *
 * miscellaneous helper functions that don't really fit elsewhere *)


exception String_of_tm_mon_failure of string
exception String_of_tm_wday_failure of string
exception Unicode_length_failure of string

(* append a file to a directory, with the proper number
 * of slashes *)
let join_path dirname filename =
   let dir_last   = dirname.[String.length dirname - 1]
   and file_first = filename.[0] in
   if dir_last = '/' && file_first = '/' then
      dirname ^ (Str.string_after filename 1)
   else if dir_last <> '/' && file_first <> '/' then
      dirname ^ "/" ^ filename
   else
      dirname ^ filename


(* Perform shell expansion of environment variables. *)
let shell_expand text =
   let split_regex = Str.regexp "=" in
   (* Get a list of all environment variable mappings *)
   let add_mapping env_mapping mapping_list =
      match Str.split split_regex env_mapping with
      | key :: value :: [] -> 
         (key, value) :: mapping_list 
      | _ ->
         mapping_list
   in
   let env_mappings = Array.fold_right add_mapping (Unix.environment ()) [] in
   let rec apply_mappings mapping_list s =
      match mapping_list with
      | [] ->
         s
      | (var, expansion) :: tail ->
         let var_regex = Str.regexp_string ("$" ^ var) in
         apply_mappings tail (Str.global_replace var_regex expansion s)
   in
   apply_mappings env_mappings text

   
(* If the filename starts with "~", substitute $HOME.  Then do shell
 * expansion on the resulting string. *)
let expand_file filename =
   let tilde_expansion = 
      if String.length filename >= 2 && Str.string_before filename 2 = "~/" then
         "$HOME" ^ Str.string_after filename 1
      else
         filename
   in
   shell_expand tilde_expansion


(* Do whatever is necessary to open up a file for writing.  If it already exists,
 * open it as-is.  If it does not exist, make sure that all prefix directories
 * do exist, then open a new file. *)
let open_or_create_out_gen is_binary filename =
   let exp_file = expand_file filename in
   (* Test whether the file exists *)
   if Sys.file_exists exp_file then
      if is_binary then
         open_out_bin exp_file
      else
         open_out exp_file
   else
      (* Check whether all directories exist *)
      let dir_path = Filename.dirname exp_file in
      let dir_list = Str.split (Str.regexp "/+") dir_path in
      (* if necessary, add the first "/" to the first directory *)
      let slash_dir_list =
         if not (Filename.is_relative dir_path) then
            ("/" ^ (List.hd dir_list)) :: (List.tl dir_list)
         else
            dir_list
      in
      let rec make_directories d_list =
         match d_list with
         | [] ->
            ()
         | d :: tail ->
            begin
               try Sys.chdir d
               with Sys_error err_msg ->
                  begin 
                     let _ = Sys.command ("mkdir " ^ d) in
                     Sys.chdir d
                  end
            end;
            make_directories tail
      in
      make_directories slash_dir_list;
      if is_binary then
         open_out_bin (Filename.basename exp_file)
      else
         open_out (Filename.basename exp_file)


let open_or_create_out_bin filename =
   open_or_create_out_gen true filename

let open_or_create_out_ascii filename =
   open_or_create_out_gen false filename



(* open a filename, with tilde/$HOME expansion *)
let expand_open_in_gen is_binary filename =
   (* If the filename starts with "~", substitute $HOME *)
   if is_binary then
      open_in_bin (expand_file filename)
   else
      open_in (expand_file filename)


let expand_open_in_bin filename =
   expand_open_in_gen true filename

let expand_open_in_ascii filename =
   expand_open_in_gen false filename



let string_of_tm_mon i =
   match i with
   | 0 -> "Jan"
   | 1 -> "Feb"
   | 2 -> "Mar"
   | 3 -> "Apr"
   | 4 -> "May"
   | 5 -> "Jun"
   | 6 -> "Jul"
   | 7 -> "Aug"
   | 8 -> "Sep"
   | 9 -> "Oct"
   |10 -> "Nov"
   |11 -> "Dec"
   | x -> raise (String_of_tm_mon_failure ("unknown month " ^ (string_of_int x)))

let full_string_of_tm_mon i =
   match i with
   | 0 -> "January"
   | 1 -> "February"
   | 2 -> "March"
   | 3 -> "April"
   | 4 -> "May"
   | 5 -> "June"
   | 6 -> "July"
   | 7 -> "August"
   | 8 -> "September"
   | 9 -> "October"
   |10 -> "November"
   |11 -> "December"
   | x -> raise (String_of_tm_mon_failure ("unknown month " ^ (string_of_int x)))

let short_string_of_tm_wday i =
   match i with
   | 0 -> "Su"
   | 1 -> "Mo"
   | 2 -> "Tu"
   | 3 -> "We"
   | 4 -> "Th"
   | 5 -> "Fr"
   | 6 -> "Sa"
   | x -> raise (String_of_tm_wday_failure ("unknown weekday " ^ (string_of_int x)))

let string_of_tm_wday i =
   match i with
   | 0 -> "Sun"
   | 1 -> "Mon"
   | 2 -> "Tue"
   | 3 -> "Wed"
   | 4 -> "Thu"
   | 5 -> "Fri"
   | 6 -> "Sat"
   | x -> raise (String_of_tm_wday_failure ("unknown weekday " ^ (string_of_int x)))

let full_string_of_tm_wday i =
   match i with
   | 0 -> "Sunday"
   | 1 -> "Monday"
   | 2 -> "Tuesday"
   | 3 -> "Wednesday"
   | 4 -> "Thursday"
   | 5 -> "Friday"
   | 6 -> "Saturday"
   | x -> raise (String_of_tm_wday_failure ("unknown weekday " ^ (string_of_int x)))



(* it's useful to have an empty date record to save some typing *)
let empty_tm = {
   Unix.tm_sec   = 0;
   Unix.tm_min   = 0;
   Unix.tm_hour  = 0;
   Unix.tm_mday  = 1;
   Unix.tm_mon   = 0;
   Unix.tm_year  = 1900;
   Unix.tm_wday  = 0;
   Unix.tm_yday  = 0;
   Unix.tm_isdst = false
}


(* strip whitespace *)

let lstrip s =
   (* Any amount of whitespace, followed by a non-whitespace char,
    * followed by any number of characters.  If match fails,
    * then the string must be entirely whitespace. *)
   let re = Str.regexp "[ \t]*\\([^ \t].*\\)" in
   if Str.string_match re s 0 then
      Str.replace_first re "\\1" s
   else
      ""

let rstrip s =
   (* Any number of characters, followed by a non-whitespace char,
    * followed by any number of whitespace chars.  If match
    * fails, then the string must be entirely whitespace. *)
   let re = Str.regexp "\\(.*[^ \t]\\).*" in
   if Str.string_match re s 0 then
      Str.replace_first re "\\1" s
   else
      ""

let strip s = lstrip (rstrip s)
      

(* Use the shell to open a process, read all output from both stdout and stderr, 
 * and close the pipes to the process again.  Returns a list of lines from
 * stdout, and a list of lines from stderr.
 *
 * Uses select(), so it should be robust to I/O buffering synchronization
 * issues. *)
let read_all_shell_command_output shell_command =
   let (in_read, in_write)   = Unix.pipe ()
   and (out_read, out_write) = Unix.pipe ()
   and (err_read, err_write) = Unix.pipe () in
   let rec read_output out_str err_str out_done err_done =
      if out_done && err_done then
         (out_str, err_str)
      else begin
         let out_lst = if out_done then [] else [out_read]
         and err_lst = if err_done then [] else [err_read] in
         (* find some output to read *)
         let (read_list, _, _) = Unix.select (out_lst @ err_lst) [] [] (10.0) in
         if List.length read_list > 0 then begin
            let chan = List.hd read_list in
            let buf = String.make 256 ' ' in
            let chars_read = Unix.read chan buf 0 256 in
            if chars_read = 0 then
               (* no chars read indicates EOF *)
               if chan = out_read then
                  read_output out_str err_str true err_done
               else
                  read_output out_str err_str out_done true
            else
               (* if 1-256 characters are read, append them to the proper
                * buffer and continue *)
               let s = String.sub buf 0 chars_read in
               if chan = out_read then
                  read_output (out_str ^ s) err_str out_done err_done
               else
                  read_output out_str (err_str ^ s) out_done err_done
         end else
            (out_str, err_str)
      end
   in
   (* launch the shell process *)
   let pid = 
      Unix.create_process "/bin/sh" [| "/bin/sh"; "-c"; shell_command |] 
      in_read out_write err_write 
   in
   (* these belong to remind, so close them off *)
   Unix.close in_read;
   Unix.close out_write;
   Unix.close err_write;
   let (out_str, err_str) = read_output "" "" false false in
   (* clean up remind zombie *)
   let _ = Unix.waitpid [] pid in
   (* close off our end of the IPC pipes *)
   Unix.close in_write;
   Unix.close out_read;
   Unix.close err_read;
   let newline_regex = Str.regexp "\n" in
   let out_lines = Str.split newline_regex out_str
   and err_lines = Str.split newline_regex err_str in
   (out_lines, err_lines)


(* Compute the number of bytes required to store a utf-8 character.
 * Input is the first byte of the character. *)
let utf8_width (byte : char) =
   let c = Char.code byte in
   if      c < 0x80 then 1
   else if c < 0xc0 then raise (Unicode_length_failure "illegal byte")
   else if c < 0xe0 then 2
   else if c < 0xf0 then 3
   else if c < 0xf8 then 4
   else if c < 0xfc then 5
   else if c < 0xfe then 6
   else
      raise (Unicode_length_failure "illegal byte")
   

(* Compute the number of UTF-8 characters contained in an ocaml String. *)
let utf8_len s =
   let s_len = String.length s in
   let rec len_aux byte_pos char_count =
      if byte_pos >= s_len then
         char_count
      else
         let num_bytes = utf8_width s.[byte_pos] in
         len_aux (byte_pos + num_bytes) (succ char_count)
   in
   if Curses.Curses_config.wide_ncurses then
      len_aux 0 0
   else
      (* If build process does not detect ncursesw, then fall back
       * on standard string behavior. *)
      s_len


(* Form the substring of all characters from 's' in positions before 'n',
 * where 'n' may be measured in characters rather than bytes.  Does the right
 * thing for utf-8 wide characters. *)
let utf8_string_before s n =
   let rec build_substr substr utf8_pos byte_pos =
      if utf8_pos >= n then
         substr
      else
         let num_new_bytes = utf8_width s.[byte_pos] in
         let new_bytes = String.make num_new_bytes s.[byte_pos] in
         for i = 1 to pred num_new_bytes do
            new_bytes.[i] <- s.[byte_pos + i]
         done;
         build_substr (substr ^ new_bytes) (succ utf8_pos) 
            (byte_pos + num_new_bytes)
   in
   if Curses.Curses_config.wide_ncurses then
      build_substr "" 0 0
   else
      (* If we're not using utf-8, fall back on standard string behavior. *)
      Str.string_before s n


(* Form the substring of all characters from 's' in positions 'n' or greater,
 * where 'n' may be measured in characters rather than bytes.  Does the right
 * thing for utf-8 wide characters. *)
let utf8_string_after s n =
   if Curses.Curses_config.wide_ncurses then begin
      let starting_byte = ref 0 in
      for utf8_char = 0 to pred n do
         starting_byte := !starting_byte + (utf8_width s.[!starting_byte])
      done;
      Str.string_after s !starting_byte
   end else
      (* If we're not using utf-8, fall back on standard string behavior. *)
      Str.string_after s n



(* arch-tag: DO_NOT_CHANGE_a87790db-2dd0-496c-9620-ed968f3253fd *)