Answer of exercise 8

This exercise combines the previous exercise (exercise 2.16) and the recursive file copy (exercise 2.15).

One small difficulty is the management of permissions: we must create the archive’s directories with write permission and set them to their actual value only after all the files were extracted.

Let us first write an auxiliary function for mkpath p m that creates the missing directories along the path p with permissions m (and such that p may be terminated by a superfluous “/”).

let warning mes = prerr_string mes;prerr_newline ();; open Filename let mkpath p perm = let normal_path = if basename p = "" then dirname p else p in let path_to_dir = dirname normal_path in let rec make p = try ignore (stat p) with Unix_error (ENOENT, _, _) -> if p = current_dir_name then () else if p = parent_dir_name then warning "Ill formed archive: path contains \"..\"" else begin make (dirname p); mkdir p perm end in make path_to_dir;;

We also define a function set_infos similar to the one used to copy files (section 2.15):

let set_infos header = chmod header.name header.perm; let mtime = float header.mtime in utimes header.name mtime mtime; begin match header.kind with | LNK f -> () | _ -> chmod header.name header.perm end; try chown header.name header.uid header.gid with Unix_error(EPERM,_,_) -> ();;

The main function of the program is untar_file_collect_dirs which processes a single record and accumulates directories explicitly created by the archive:

let verbose = ref true;; let default_dir_perm = 0o777;; let default_file_perm = 0o666;; let protect f x g y = try f x; g y with z -> g y; raise z let file_exists f = try ignore (stat f); true with _ -> false;; let untar_file_collect_dirs file dirs = let fh = file.header in if !verbose then begin print_string fh.name; print_newline () end; match fh.kind with | CHR (_,_) | BLK(_,_) | FIFO -> warning (fh.name ^ "Ignoring special files"); dirs | DIR -> mkpath fh.name default_dir_perm; if file_exists fh.name then dirs else begin mkdir fh.name default_dir_perm; fh :: dirs end | x -> mkpath fh.name default_dir_perm; begin match x with | REG | CONT -> let flags = [ O_WRONLY; O_TRUNC; O_CREAT; ] in let out = openfile fh.name flags default_file_perm in protect (copy_file file) out close out | LNK f -> symlink f fh.name | LINK f -> begin try if (stat fh.name).st_kind = S_REG then unlink fh.name with Unix_error(_,_,_) -> (); end; Unix.link f fh.name; | _ -> assert false end; set_infos fh; dirs;;

The body of the program just iterates untar_file_collect_dirs on the records and finally updates the directories with the correct access rights.

let extract tarfile = let fd = openfile tarfile [ O_RDONLY ] 0 in let new_directories = fold untar_file_collect_dirs [] fd in List.iter set_infos new_directories; close fd;;
let untar () = let nargs = Array.length Sys.argv in if nargs = 2 then extract Sys.argv.(1) else prerr_endline ("Usage: " ^ Sys.argv.(0) ^ " <tarfile>");; handle_unix_error untar ();;
* * *