Nous réutilisons les structures de données définies ci-dessus dans la bibliothèque Tarlib. Nous ajoutons au report d’erreurs les messages d’avertissement qui n’arrêtent pas l’archivage et n’altère pas le code de retour.
     
   open Sys
   open Unix
   open Tarlib
   
   let warning path message =  prerr_endline (path ^ ": " ^ message)
Commençons par l’écriture d’un entête de type header dans un buffer de taille suffisante (donc au moins la taille d’un bloc). L’écriture de cette fonction est ennuyante, mais doit être faite avec soin car une seule erreur dans l’écriture de l’entête peut corrompre toute l’archive, comme bien souvent en informatique. On fera attention en particulier de respecter les limites imposées dans l’archivage. Par exemple, la taille des chemins est limitée à 99 octets. Il existe des extensions du format des archives qui permettent de traiter des chemins de taille plus longue, mais ce n’est pas le but du projet.
     
   let write_header_to_buffer source infos kind =
     let size = if kind = REG then infos.st_size else 0 in
     String.fill buffer 0 block_size '\000';
     let put len string offset =
       String.blit string 0 buffer offset (min (String.length stringlenin
     let put_int8 x = put 7 (Printf.sprintf "%07o" xin
     let put_int12 x = put 11 (Printf.sprintf "%011o" xin
     let put_char c offset = buffer.[offset] <- c in
     let put_path s offset =
       if String.length s <= 99 then put 99 s offset
       else raise (Error ("path too long"s)) in
     put_path (if kind = DIR then source ^ "/" else source) 0;
     put_int8 infos.st_perm 100;
     put_int8 infos.st_uid 108;
     put_int8 infos.st_gid 116;
     put_int12 size 124;
     put_int12 (int_of_float infos.st_mtime) 136;
     put 7 "ustar  " 257;
     put 31 (getpwuid infos.st_uid).pw_name 265;
     put 31 (getgrgid infos.st_gid).gr_name 297;
     (* Fields dev and rdev are only used for special files, which we omit *)
     put_char
       begin match kind with
       | REG -> '0'
       | LINK s -> put_path s 157; '1'
       | LNK s ->  put_path s 157; '2'
       | DIR -> '5'
       | _ -> failwith "Special files not implemented"
       end 156;
     let rec sum s i =
       if i < 0 then s else sum (s + Char.code buffer.[i]) (pred iin
     let checksum = sum (Char.code ' ' * 8) (block_size - 1)  in
     put 8 (Printf.sprintf "%06o\000 " checksum) 148;;
À l’inverse, nous créons un entête à partir d’une entrée d’une archive: source est le nom du fichiers; infos sont les informations sur le fichier (de type stats) et kind est le type du fichier dans l’archive (type Tarlib.kind).
     
   let header source infos kind = {
     name = source;
     size = if kind = REG then infos.st_size else 0;
     perm = infos.st_perm;
     mtime = int_of_float infos.st_mtime;
     uid = infos.st_uid;
     gid = infos.st_gid;
     user = (getpwuid infos.st_uid).pw_name;
     group = (getgrgid infos.st_gid).gr_name;
     kind = kind }
Pour écrire un fichier dans l’archive, nous définissons une variante de file_copy qui prend en argument le nombre d’octets à copier et vérifie que la fin de fichier correspond bien à la taille indiquée. Sinon, une erreur est levée: celle-ci correspond à un cas pathologique où le fichier est en train d’être modifié pendant l’archivage. On prend soin de ne jamais dépasser la taille indiquée, ce qui limitera la corruption d’une archive à un seul fichier.
     
   let write_file len source fdout =
     let fdin = openfile source [O_RDONLY] 0 in
     let error () = raise (Error ("File changed size"source)) in
     let rec copy_loop len =
       match read fdin buffer 0 buffer_size with
         0 ->
           close fdinif len > 0 then error ()
       | r ->
           let len = len - r  in
           if len < 0 then (close fdinerror());
           ignore (write fdout buffer 0 r); copy_loop len in
     copy_loop len;;
   
   let padding fd len =
     if len > 0 then ignore (write fd (String.make len '\000') 0 len);;
Nous pouvons maintenant nous attaquer à la lecture de la création de l’archive. Les fichiers déjà enregistrés dans l’archive sont mémorisés dans une table de hache avec leur chemin dans l’archive afin de ne les recopier qu’une seule fois. Nous allons mémoriser également les répertoires déjà enregistrés afin de ne pas les recopier à nouveau: en effet il peut arriver qu’une racine d’archivage soit déjà contenue dans une autre. On évitera de la recopier (bien qu’il ne serait pas grave de le faire).

Une archive en cours d’écriture est donc identifiée par le descripteur dans lequel elle est écrite et ses deux caches. Nous ajoutons un champ qui maintient la taille de l’archive, afin de pouvoir compléter celle-ci pour atteindre une taille minimale.

     
   type archive =
       { regfiles : (int * intstringHashtbl.t;
         dirfiles : (int * intboolHashtbl.t;
         fd : file_descrst : statsmutable size : int }
   
   let try_new_dir archive dir =
     try Hashtbl.find archive.dirfiles dir
     with Not_found -> Hashtbl.add archive.dirfiles dir falsetrue

Voici la fonction principale qui écrit toute une arborescence à partir d’une entrée dans l’archive file passée sur la ligne de commande. Cette fonction n’est pas difficile, mais il faut prendre quelques précautions par rapport aux cas pathologiques. En particulier, nous allons vu comment détecter le cas fichier en train d’être modifié pendant son archivage. Un sous-cas de celui-ci est lorsque l’archive est elle-même est en train d’être archivée...

     
   let verbose = ref true;;
   
   let write_from archive file =
     if not (Filename.is_relative filethen
       raise (Error ("absolute path"file));
     let rec write_rec archive file =
       let source =
         if Filename.basename file = "" then Filename.dirname file else file in
       if !verbose then begin prerr_endline source end;
       let st = lstat source in
       if st.st_ino = archive.st.st_ino && st.st_dev = archive.st.st_dev
       then warning source "Skiping archive itself!"
       else
         let write_header kind =
           write_header_to_buffer source st kind;
           ignore (write archive.fd buffer 0 block_sizein
         match st.st_kind with
           S_REG ->
             begin try
               if st.st_nlink = 1 then raise Not_found;
               let path =
                 Hashtbl.find archive.regfiles (st.st_inost.st_devin
               write_header (LINK path);
             with Not_found ->
               if st.st_nlink > 1 then
                 Hashtbl.add archive.regfiles (st.st_inost.st_devsource;
               write_header REG;
               write_file st.st_size source archive.fd;
               let t =
                 (block_size-1 + st.st_size) / block_size * block_size in
               padding archive.fd (t - st.st_size);
               archive.size <- archive.size + t + block_size;
             end
         | S_LNK ->
             write_header (LNK (readlink source));
         | S_DIR when try_new_dir archive (st.st_inost.st_dev) ->
             write_header DIR;
             Misc.iter_dir
               begin
                 fun file ->
                   if file = Filename.current_dir_name then ()
                   else if file = Filename.parent_dir_name then ()
                   else write_rec archive (source ^ "/" ^ file)
               end
               source
         | S_DIR ->
             warning source "Ignoring directory already in archive."
         | _ ->
             prerr_endline ("Can't cope with special file " ^ sourcein
     write_rec archive file;;

Nous mémorisons les fichiers réguliers qui peuvent avoir de liens durs dans la table regfiles. Ce n’est pas nécessaire pour les fichiers qui n’ont qu’un seul lien (lignes 91 et 96).

Il ne reste plus qu’à finir le programme. En cas d’erreur, il est plus prudent de retirer l’archive erronée.

     
   let min_archive_size = 20 * block_size;;
   
   let build tarfile files =
     let fdremove =
       if tarfile = "-" then stdoutignore
       else openfile tarfile [ O_WRONLYO_CREATO_TRUNC ] 0o666unlink in
     try
       let arch =
            { regfiles = Hashtbl.create 13; dirfiles = Hashtbl.create 13;
              st = fstat fdfd = fdsize =0 } in
       Array.iter (write_from archfiles;
       padding fd (min_archive_size - arch.size);
       close fd
     with z ->
       remove tarfileclose fdraise z;;

Pour terminer il ne reste plus qu’à analyser la ligne de commande.

     
   let usage() =
     prerr_endline "Usage: tar -cvf tarfile file1 [ file2 ... ] ";
     exit 2;;
   
   let tar () =
     let argn = Array.length Sys.argv in
     if argn > 3 && Sys.argv.(1) = "-cvf" then
       build Sys.argv.(2) (Array.sub Sys.argv 3 (argn-3))
     else usage();;
   
   let _ =
     try handle_unix_error tar ()
     with Error (mess) ->
       prerr_endline ("Error: " ^ mes ^ ": " ^ s); exit 1;;