libmojave/stdlib/lm_io.ml

   1 (*
   2  * $Id: lm_io.ml 7878 2005-10-09 00:13:24Z jyh $
   3  * Operations to do I/O
   4  *
   5  * Moved here from Pervasives
   6  *)
   7
   8 open String
   9
  10 (*
  11  * Reading.
  12  *)
  13 external fopen : string -> int -> int -> int = "%file_open"
  14 external fclose : int -> unit = "%file_close"
  15 external fread : int -> string -> int -> int -> int = "%file_read"
  16 external fwrite : int -> string -> int -> int -> int = "%file_write"
  17 external fseek : int -> int -> unit = "%file_seek"
  18 external ftell : int -> int = "%file_tell"
  19 external flength : int -> int = "%file_len"
  20
  21 let code = int_of_char
  22 let chr = char_of_int
  23
  24 (*
  25  * An in-channel contains a buffer.
  26  *)
  27 type channel =
  28    { mutable chan_fd : int;
  29      chan_buf : string;
  30      mutable chan_min : int;
  31      mutable chan_max : int
  32    }
  33
  34 type in_channel = channel
  35 type out_channel = channel
  36
  37 (*
  38  * Buffer operations.
  39  *)
  40 let bufsize = 8192
  41
  42 let mk_chan fd =
  43    { chan_fd = fd;
  44      chan_buf = screate bufsize;
  45      chan_min = 0;
  46      chan_max = 0
  47    }
  48
  49 let stdin = mk_chan 0
  50 let stdout = mk_chan 1
  51 let stderr = mk_chan 2
  52
  53 (*
  54  * Convert the open flags.
  55  *)
  56 type open_flag =
  57    Open_rdonly
  58  | Open_wronly
  59  | Open_append
  60  | Open_creat
  61  | Open_trunc
  62  | Open_excl
  63  | Open_binary
  64  | Open_text
  65  | Open_nonblock
  66
  67 let o_rdonly   = 1
  68 let o_wronly   = 2
  69 let o_rdwr     = 3
  70 let o_creat    = 4
  71 let o_excl     = 8
  72 let o_noctty   = 16
  73 let o_trunc    = 32
  74 let o_append   = 64
  75 let o_nonblock = 128
  76 let o_sync     = 256
  77 let o_binary   = 512
  78
  79 let rec mask_of_flags mask = function
  80    h :: t ->
  81       let mask' =
  82          match h with
  83             Open_rdonly -> o_rdonly
  84           | Open_wronly -> o_wronly
  85           | Open_append -> o_append
  86           | Open_creat -> o_creat
  87           | Open_trunc -> o_trunc
  88           | Open_excl -> o_excl
  89           | Open_binary -> o_binary
  90           | Open_text -> 0
  91           | Open_nonblock -> o_nonblock
  92       in
  93          mask_of_flags (mask lor mask') t
  94  | [] ->
  95       mask
  96
  97 (*
  98  * Opening and closing.
  99  *)
 100 let open_gen mask flags umask name =
 101    let mask = mask_of_flags 0 flags in
 102    let fd = fopen name mask umask in
 103       if fd < 0 then
 104          raise (Sys_error name);
 105       mk_chan fd
 106
 107 let open_out_gen = open_gen o_wronly
 108 let open_in_gen = open_gen o_rdonly
 109
 110 let open_out_bin = open_gen (o_wronly lor o_binary) [] 438
 111 let open_out = open_gen o_wronly [] 438
 112
 113 let open_in_bin = open_gen (o_rdonly lor o_binary) [] 0
 114 let open_in = open_gen o_rdonly [] 0
 115
 116 let close chan =
 117    let fd = chan.chan_fd in
 118       if fd >= 0 then
 119          fclose fd;
 120       chan.chan_fd <- (-1)
 121
 122 let close_in = close
 123 let close_out = close
 124
 125 (*
 126  * Filling and flushing.
 127  *)
 128 let filbuf chan =
 129    let { chan_fd = fd; chan_buf = buf } = chan in
 130    let count = fread fd buf 0 bufsize in
 131       if count <= 0 then
 132          raise End_of_file;
 133       chan.chan_min <- 0;
 134       chan.chan_max <- count
 135
 136 let flush chan =
 137    let { chan_fd = fd; chan_buf = buf; chan_min = min; chan_max = max } = chan in
 138    let rec writebuf min =
 139       if min < max then
 140          let count = max - min in
 141          let count = fwrite fd buf min count in
 142             if count <= 0 then
 143                begin
 144                   chan.chan_min <- min;
 145                   raise End_of_file
 146                end;
 147             writebuf (min + count)
 148    in
 149       writebuf min;
 150       chan.chan_min <- 0;
 151       chan.chan_max <- 0
 152
 153 (*
 154  * Output.
 155  *)
 156 let output_char chan c =
 157    if chan.chan_max = bufsize then
 158       flush chan;
 159    let max = chan.chan_min in
 160       chan.chan_buf.[max] <- c;
 161       chan.chan_max <- succ max
 162
 163 let rec writebuf fd buf off len =
 164    if off < len then
 165       let count = len - off in
 166       let count = fwrite fd buf off count in
 167          if count <= 0 then
 168             raise End_of_file;
 169          writebuf fd buf (off + count) len
 170
 171 let output chan buf off len =
 172    if len - off >= bufsize then
 173       begin
 174          flush chan;
 175          writebuf chan.chan_fd buf off len;
 176          chan.chan_min <- 0;
 177          chan.chan_max <- 0
 178       end
 179    else
 180       begin
 181          if chan.chan_max + len - off > bufsize then
 182             flush chan;
 183          sblit buf off chan.chan_buf chan.chan_max len;
 184          chan.chan_max <- chan.chan_max + len
 185       end
 186
 187 let output_string chan s =
 188    output chan s 0 (slength s)
 189
 190 let output_byte chan i =
 191    output_char chan (chr i)
 192
 193 let output_binary_int chan i =
 194    output_byte chan ((i lsr 24) land 255);
 195    output_byte chan ((i lsr 16) land 255);
 196    output_byte chan ((i lsr 8) land 255);
 197    output_byte chan (i land 255)
 198
 199 let seek_out chan loc =
 200    flush chan;
 201    fseek chan.chan_fd loc
 202
 203 let pos_out chan =
 204    flush chan;
 205    ftell chan.chan_fd
 206
 207 let out_channel_length chan =
 208    flush chan;
 209    flength chan.chan_fd
 210
 211 let set_binary_mode_out chan flag =
 212    ()
 213
 214 (*
 215  * Input.
 216  *)
 217 let ungetc chan =
 218    let min = chan.chan_min in
 219       if min = 0 then
 220          raise (Invalid_argument "ungetc");
 221       chan.chan_min <- pred min
 222
 223 let set_binary_mode_in chan flag =
 224    ()
 225
 226 let rec input_char chan =
 227    let { chan_buf = buf; chan_min = min; chan_max = max } = chan in
 228       if min = max then
 229          begin
 230             filbuf chan;
 231             input_char chan
 232          end
 233       else
 234          begin
 235             chan.chan_min <- succ min;
 236             buf.[min]
 237          end
 238
 239 let input_byte chan =
 240    code (input_char chan)
 241
 242 let input_binary_int chan =
 243    let c1 = input_byte chan in
 244    let c2 = input_byte chan in
 245    let c3 = input_byte chan in
 246    let c4 = input_byte chan in
 247       ((c1 lsl 24) lor (c2 lsl 16) lor (c3 lsl 8) lor c4)
 248
 249 let rec input_line chan =
 250    let { chan_buf = buf; chan_min = min; chan_max = max } = chan in
 251       if min = max then
 252          begin
 253             filbuf chan;
 254             input_line chan
 255          end
 256       else
 257          let rec search s i min max =
 258             if i = max then
 259                let s = s ^ (ssub buf min max) in
 260                   try
 261                      filbuf chan;
 262                      search s chan.chan_min chan.chan_min chan.chan_max
 263                   with
 264                      End_of_file ->
 265                         s
 266             else if buf.[i] = '\n' then
 267                let s = s ^ (ssub buf min i) in
 268                   chan.chan_min <- succ i;
 269                   s
 270             else
 271                search s (succ i) min max
 272          in
 273             search "" chan.chan_min chan.chan_min chan.chan_max
 274
 275 let input chan buf off len =
 276    if chan.chan_min = chan.chan_max then
 277       filbuf chan;
 278    let { chan_buf = buf'; chan_min = min'; chan_max = max' } = chan in
 279    let count = max' - min' in
 280       if count < len then
 281          begin
 282             sblit buf' min' buf off count;
 283             chan.chan_min <- 0;
 284             chan.chan_max <- 0;
 285             count
 286          end
 287       else
 288          begin
 289             sblit buf' min' buf off len;
 290             chan.chan_min <- min' + len;
 291             len
 292          end
 293
 294 let really_input chan buf off len =
 295    let rec read amount off len =
 296       if off < len then
 297          let { chan_buf = buf'; chan_min = min'; chan_max = max' } = chan in
 298          let count = max' - min' in
 299             if count < len then
 300                let amount = amount + count in
 301                let _ = sblit buf' min' buf off count in
 302                let off = off + count in
 303                let len = len - count in
 304                   filbuf chan;
 305                   read amount off len
 306             else
 307                let amount = amount + len in
 308                   sblit buf' min' buf off len;
 309                   chan.chan_min <- chan.chan_min + len
 310    in
 311       read 0 off len
 312
 313 (*
 314  * Seeking.
 315  *)
 316 let seek_in chan pos =
 317    chan.chan_min <- 0;
 318    chan.chan_max <- 0;
 319    fseek chan.chan_fd pos
 320
 321 let pos_in chan =
 322    let pos = ftell chan.chan_fd in
 323       pos - (chan.chan_max - chan.chan_min)
 324
 325 let in_channel_length chan =
 326    flength chan.chan_fd
 327
 328 (*
 329  * Standard operations.
 330  *)
 331 let print_char = output_char stdout
 332
 333 let print_string = output_string stdout
 334
 335 let print_int i =
 336    print_string (string_of_int i)
 337
 338 let print_float x =
 339    print_string (string_of_float x)
 340
 341 let print_newline () =
 342    print_char '\n'
 343
 344 let print_endline s =
 345    print_string s;
 346    print_newline ()
 347
 348 let prerr_char = output_char stderr
 349
 350 let prerr_string = output_string stderr
 351
 352 let prerr_int i =
 353    prerr_string (string_of_int i)
 354
 355 let prerr_float x =
 356    prerr_string (string_of_float x)
 357
 358 let prerr_newline () =
 359    prerr_char '\n'
 360
 361 let prerr_endline s =
 362    prerr_string s;
 363    prerr_newline ()
 364
 365 let read_line () =
 366    input_line stdin
 367
 368 let is_digit = function
 369    '0'
 370  | '1'
 371  | '2'
 372  | '3'
 373  | '4'
 374  | '5'
 375  | '6'
 376  | '7'
 377  | '8'
 378  | '9' ->
 379       true
 380  | _ ->
 381       false
 382
 383 let int_of_digit = function
 384    '0' -> 0
 385  | '1' -> 1
 386  | '2' -> 2
 387  | '3' -> 3
 388  | '4' -> 4
 389  | '5' -> 5
 390  | '6' -> 6
 391  | '7' -> 7
 392  | '8' -> 8
 393  | '9' -> 9
 394  | _ ->
 395       raise (Invalid_argument "int_of_digit")
 396
 397 let is_space = function
 398    ' '
 399  | '\t'
 400  | '\r'
 401  | '\n' ->
 402       true
 403
 404  | _ ->
 405       false
 406
 407 (*
 408  * Skip white space.
 409  *)
 410 let rec skip_white chan =
 411    let c = input_char chan in
 412       if is_space c then
 413          skip_white chan
 414       else
 415          ungetc chan
 416
 417 (*
 418  * Read an integer.
 419  *)
 420 let input_int chan =
 421    skip_white chan;
 422    let c = input_char chan in
 423    let negate =
 424       if c = '-' then
 425          true
 426       else
 427          begin
 428             ungetc chan;
 429             false
 430          end
 431    in
 432    let rec input i =
 433       let c = input_char chan in
 434          if is_digit c then
 435             input (i * 10 + int_of_digit c)
 436          else
 437             begin
 438                ungetc chan;
 439                if negate then
 440                   -i
 441                else
 442                   i
 443             end
 444    in
 445       input 0
 446
 447 (*
 448  * Read a floating point number.
 449  *)
 450 type float_state =
 451    FloatInt
 452  | FloatDecimal
 453  | FloatExponent
 454  | FloatSignedExponent
 455
 456 let fbufsize = 256
 457
 458 let input_float chan =
 459    let buf = screate fbufsize in
 460    let _ = skip_white chan in
 461    let c = input_char chan in
 462    let negate =
 463       if c == '-' then
 464              true
 465       else
 466          begin
 467             ungetc chan;
 468             false
 469          end
 470    in
 471    let rec loop state i =
 472       if i = fbufsize then
 473          i
 474       else
 475          let c = input_char chan in
 476             buf.[i] <- c;
 477             match state with
 478                FloatInt ->
 479                   if is_digit c then
 480                      loop FloatInt (succ i)
 481                   else if c == '.' then
 482                      loop FloatDecimal (succ i)
 483                   else if c == 'e' || c == 'E' then
 484                      loop FloatExponent (succ i)
 485                   else
 486                      (ungetc chan; i)
 487
 488
 489              | FloatDecimal ->
 490                   if is_digit c then
 491                      loop FloatDecimal (succ i)
 492                   else if c == 'e' || c == 'E' then
 493                      loop FloatExponent (succ i)
 494                   else
 495                      (ungetc chan; i)
 496
 497              | FloatExponent ->
 498                   if c == '-'  || c == '+' then
 499                      loop FloatSignedExponent (succ i)
 500                   else if is_digit c then
 501                      loop FloatSignedExponent (succ i)
 502                   else
 503                      (ungetc chan; i)
 504
 505              | FloatSignedExponent ->
 506                   if is_digit c then
 507                      loop FloatSignedExponent (succ i)
 508                   else
 509                      (ungetc chan; i)
 510    in
 511    let i = loop FloatInt 0 in
 512       float_of_string (ssub buf 0 i)
 513
 514 let read_int () =
 515    input_int stdin
 516
 517 let read_float () =
 518    input_float stdin