Une solution assez simple consiste à simuler l’effet de l’extraction en créant dans un graphe une image de la hiérarchie des fichiers contenus dans l’archive.

     
   type info = File | Link of string list | Dir of (string * inode) list
   and inode = { mutable record : record option; mutable info : info;}

Les nœuds du système de fichier virtuel dont décrits par le type inode. Le champ info décrit le type de fichier en se limitant aux fichiers ordinaires, liens symboliques et répertoires. Les chemins sont représentés par des listes de chaînes de caractères et les répertoires par des listes qui associent un nœud à chaque nom de fichiers du répertoire. Le champ record le fichier associé au nœud dans l’archive. Ce champ est optionnel, car les répertoires intermédiaires ne sont pas toujours décrits dans l’archive; il est mutable, car un fichier peut apparaître plusieurs fois dans l’archive, et les dernières informations sont prioritaires.

     
   let root () =
     let rec i =
       { record = None; info = Dir [ Filename.current_dir_name, i ] }
     in i
   let link inode name nod =
     match inode.info with
     | File | Link _ -> error name "Not a directory"
     | Dir list ->
         try let _ = List.assoc name list in error name "Already exists"
         with Not_found -> inode.info <- Dir ((name, nod) :: list)
   
   let mkfile inode name r =
     let f =  { record = r; info = File } in
     link inode name f; f
   let symlink inode name r path =
     let s =  { record = r; info = Link path } in
     link inode name s; s
   let mkdir inode name r =
     let d = mkfile inode name r in
     d.info <-
       Dir [ Filename.current_dir_name, d; Filename.parent_dir_name, inode ];
     d

Comme en Unix, chaque répertoire contient un lien vers lui-même et un lien vers son parent, sauf le répertoire racine (contrairement à Unix où il est son propre parent). Ce choix nous permet de détecter et d’interdire l’accès en dehors de l’archive très simplement.

     
   let rec find link inode path =
     match inode.info, path with
     | _, [] -> inode
     | Dir list, name :: rest ->
         let subnode = List.assoc name list in
         let subnode =
           match subnode.info with
             Link q ->
               if link && rest = [] then subnode else find false inode q
           | _ -> subnode  in
         find link subnode rest
     | _, _ -> raise Not_found;;

La fonction find effectue une recherche dans l’archive à partir d’un nœud initial inode en suivant le chemin path. Le drapeau link indique si dans le cas où le résultat est un lien symbolique il faut retourner le lien lui-même (true) ou le fichier pointé par le lien (false).

     
   let rec mkpath inode path =
     match inode.info, path with
     | _, [] -> inode
     | Dir list, name :: rest ->
         let subnode =
           try List.assoc name list
           with Not_found ->  mkdir inode name None in
         mkpath subnode rest
     | _, _ -> raise Not_found;;

La fonction mkpath parcourt le chemin path en créant les nœuds manquant le long du chemin.

     
   let explode f =
     let rec dec f p =
       if f = Filename.current_dir_name then p
       else dec (Filename.dirname f) (Filename.basename f :: p) in
     dec (if Filename.basename f = "" then Filename.dirname f else f) [];;

La fonction explode décompose un chemin Unix en une liste de chaînes de caractères. Elle retire le “"/"” final qui est toléré dans les archives pour les noms de répertoires.

     
   let add archive r =
     match r.header.kind with
     | CHR (_,_) | BLK (_,_) | FIFO -> ()
     | kind ->
         match List.rev (explode r.header.name) with
         | []  -> ()
         | name :: parent_rev ->
             let inode = mkpath archive (List.rev parent_rev) in
             match kind with
             | DIR -> ignore (mkdir inode name (Some r))
             | REG | CONT -> ignore (mkfile inode name (Some r))
             | LNK f -> ignore (symlink inode name (Some r) (explode f))
             | LINK f -> link inode name (find true archive (explode f))
             | _ -> assert false;;

La fonction add ajoute l’enregistrement r dans l’archive. L’archive représentée par sa racine est modifiée par effet de bord.

     
   let find_and_copy tarfile filename =
     let fd = openfile tarfile [ O_RDONLY ] 0 in
     let records = List.rev (fold (fun x y -> x :: y) [] fd) in
     let archive = root() in
     List.iter (add archive) records;
     let inode =
       try find false archive (explode filename)
       with Not_found -> error filename "File not found" in
     begin match inode.record with
     | Some ({ header = { kind = (REG | CONT) }} as r) -> copy_file r stdout
     | Some _ -> error filename "Not a regular file"
     | None -> error filename "Not found"
     end;
     close fd;;

On termine comme précédemment.