l4/pkg/ocaml_toys/libiso9660/lib/src/iso9660.ml

   1 open Printf
   2
   3 external get_dev_block_size : unit -> int = "get_dev_block_size"
   4
   5 external read_block_ext : string -> int -> bool = "read_block_ext"
   6
   7 let sector_size = get_dev_block_size ()
   8
   9 exception Overflow of string
  10
  11 type dir_rec = {
  12         size    : int;
  13         sector  : int;
  14         length  : int;
  15         year    : int;
  16         month   : int;
  17         day     : int;
  18         hour    : int;
  19         min     : int;
  20         sec     : int;
  21         offset  : int;
  22         flags   : int;
  23         name    : string;
  24 }
  25
  26 type read_dir_rec = {
  27         mutable r_sector        : int;
  28         mutable r_offset        : int;
  29         mutable r_length        : int;
  30         mutable f_rec           : dir_rec;
  31 }
  32
  33 let root_sec = ref 0
  34
  35 let block_cache_rr = ref 0 (* round robin replacement strategy *)
  36 let block_cache_i = Array.make 16 (-1)
  37 let block_cache_s = Array.make 16 (String.create sector_size)
  38
  39 let read_block n =
  40         let i = ref 0 in
  41         while (!i < 16 && block_cache_i.(!i) != n) do i := !i + 1 done;
  42         if !i < 16 then block_cache_s.(!i)
  43         else begin
  44                 let i = !block_cache_rr in
  45                 let ok = read_block_ext block_cache_s.(!block_cache_rr) n in
  46                 if (not ok) then failwith ("read_block "^(string_of_int n)^" failed") else ();
  47                 block_cache_i.(!block_cache_rr) <- n;
  48                 block_cache_rr := (!block_cache_rr + 1) mod 16;
  49                 block_cache_s.(i)
  50         end
  51
  52 (* byte accessors *)
  53
  54 let read_byte s i = int_of_char s.[i]
  55
  56 let read1 s i = read_byte s i
  57
  58 let read2 s i =
  59     let ch1 = read_byte s i in
  60     let ch2 = read_byte s (i+1) in
  61     ch1 lor (ch2 lsl 8)
  62
  63 let read4 s i =
  64     let ch1 = read_byte s i in
  65     let ch2 = read_byte s (i+1) in
  66     let ch3 = read_byte s (i+2) in
  67     let ch4 = read_byte s (i+3) in
  68     if ch4 land 128 <> 0 then begin
  69         if ch4 land 64 = 0 then raise (Overflow "read4");
  70         ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24)
  71     end else begin
  72         if ch4 land 64 <> 0 then raise (Overflow "read4");
  73         ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24)
  74     end
  75
  76 let read_record s i =
  77     let r1 j = read1 s (i+j) in
  78     let r4 j = read4 s (i+j) in
  79     let size = r1 0 in
  80     let strlen = r1 32 in
  81     { size    = size;
  82                 sector  = r4 2;
  83                 length  = r4 10;
  84                 year    = r1 18 + 1900;
  85                 month   = r1 19;
  86                 day     = r1 20;
  87                 hour    = r1 21;
  88                 min     = r1 22;
  89                 sec     = r1 23;
  90                 offset  = r1 24;
  91                 flags   = r1 25;
  92                 name    = if strlen != 1 then String.sub s (i+33) strlen else if (r1 33) = 0 then "." else (assert ((r1 33)=1);"..")
  93         }
  94
  95 (* searches pvd, returns sector number of root record *)
  96 let read_primary_volume_descriptor () =
  97         let rec read_vol_desc n =
  98                 let data = read_block n in
  99                 let t = read1 data 0 in
 100                 if (t = 255) then failwith "primary volume descriptor not found" else
 101                 if (t != 1) then read_vol_desc (n+1) else
 102                 (* we found pvd *)
 103                 if ((read2 data 128) != sector_size) then failwith "logical blocksize != 2048, not supported" else
 104                 let root = read_record data 156 in (* copy of directory root record *)
 105                 assert (root.size = 34);
 106                 root.sector
 107
 108         in read_vol_desc 16
 109
 110 (* (string, next index or -1) *)
 111 let next_name s i =
 112         let (j,k) = if String.contains_from s i '/'
 113         then let j = String.index_from s i '/' in (j-i,j+1)
 114         else (String.length s - i,-1) (* -1 : leaf, no more parts *)
 115         in (String.sub s i j, k)
 116
 117 (* path: must start with '/'; returns None or Some rec *)
 118 let path_to_record path =
 119         if (path.[0] != '/') then begin eprintf "path_to_sector: path.[0] != '/'\n"; None end else
 120         if String.length path = 1 then Some (read_record (read_block !root_sec) 0) (* opendir '/' *) else
 121         let data = ref "" in
 122
 123         let rec search sector path_index =
 124                 let (name,i) = next_name path path_index in
 125                 if String.length name = 0 then None else begin
 126                         data := read_block sector;
 127                         let r = read_record !data 0 in
 128                         (* iterates through dir record list at one level, step down via calling 'search' *)
 129                         let rec scan sector index length =
 130                                 if (read1 !data index = 0) then (* no more records in this sector *)
 131                                         if (length < sector_size) then begin (* no more records at all *)
 132                                                 eprintf "path_to_sector: end of record list, but file '%s' not found\n" name; None
 133                                         end else begin (* read next sector, continue search *)
 134                                                 let next_sector = sector + 1 in
 135                                                 data := read_block next_sector;
 136                                                 scan next_sector 0 (length-sector_size)
 137                                         end
 138                                 else begin
 139                                         let r = read_record !data index in
 140                                         if String.compare name r.name = 0 then
 141                                                 if i = -1 then Some r else search r.sector i
 142                                         else
 143                                                 scan sector (index + r.size) length
 144                                 end
 145
 146                         in
 147                                 if (r.flags land 2 == 0) then None else scan sector 0 r.length
 148                 end
 149         in
 150                 search !root_sec 1
 151
 152 let lookup_file path =
 153         match path_to_record path with
 154         | None -> (0,0)
 155         | Some r -> (r.sector,r.length)
 156
 157 let opendir path =
 158         match path_to_record path with
 159         | None -> None
 160         | Some r ->
 161                 let data = read_block r.sector in
 162                 let f_r = read_record data 0 in
 163                 Some { r_sector = r.sector; r_offset = 0; r_length = r.length; f_rec = f_r }
 164
 165 let readdir r =
 166         let data = read_block r.r_sector in
 167         r.r_offset <- r.r_offset + r.f_rec.size;
 168         if (read1 data r.r_offset = 0) then begin
 169                 if (r.r_length = sector_size) then false else begin
 170                         r.r_sector <- r.r_sector + 1;
 171                         r.r_offset <- 0;
 172                         r.r_length <- r.r_length - sector_size;
 173                         r.f_rec <- read_record (read_block r.r_sector) 0;
 174                         true
 175                 end
 176         end else begin
 177                 r.f_rec <- read_record data r.r_offset;
 178                 true
 179         end
 180
 181 let () =
 182         root_sec := read_primary_volume_descriptor ();
 183
 184         Callback.register "lookup_file" lookup_file;
 185         Callback.register "opendir" opendir;
 186         Callback.register "readdir" readdir