[commit: Cabal] master: Tidy up the unpack code (0fea026)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/0fea026bf4f15cf92069ed990e441cc885d63b39

>---------------------------------------------------------------

commit 0fea026bf4f15cf92069ed990e441cc885d63b39
Author: Duncan Coutts <duncan at haskell.org>
Date:   Wed Dec 10 22:36:33 2008 +0000

    Tidy up the unpack code
    Also fix a bug for tar files that contain entries for files
    without preceding entries for the directories they are in.

>---------------------------------------------------------------

 cabal-install/Distribution/Client/Tar.hs |   38 ++++++++++++++++++-----------
 1 files changed, 23 insertions(+), 15 deletions(-)

diff --git a/cabal-install/Distribution/Client/Tar.hs b/cabal-install/Distribution/Client/Tar.hs
index 3eb8503..955441e 100644
--- a/cabal-install/Distribution/Client/Tar.hs
+++ b/cabal-install/Distribution/Client/Tar.hs
@@ -618,29 +618,37 @@ fill n c = replicate n c
 --
 
 unpack :: FilePath -> Entries -> IO ()
-unpack dir entries = extractLinks =<< extractFiles [] entries
+unpack baseDir entries = extractLinks =<< extractFiles [] entries
   where
     extractFiles _     (Fail err)            = Prelude.fail err
     extractFiles links Done                  = return links
     extractFiles links (Next entry entries') = case fileType entry of
-      NormalFile   -> BS.writeFile (dir </> fileName entry) (fileContent entry)
-                   >> extractFiles links entries'
-      HardLink     -> saveLink
-      SymbolicLink -> saveLink
-      Directory    -> createDirectoryIfMissing False (dir </> fileName entry)
-                   >> extractFiles links entries'
+      NormalFile   -> extractFile entry >> extractFiles links entries'
+      HardLink     -> extractFiles (saveLink entry links) entries'
+      SymbolicLink -> extractFiles (saveLink entry links) entries'
+      Directory    -> extractDir entry >> extractFiles links entries'
       _            -> extractFiles links entries' -- FIXME: warning?
+
+    extractFile entry = do
+      createDirectoryIfMissing False fileDir
+      BS.writeFile fullPath (fileContent entry)
+      where
+        fileDir  = baseDir </> FilePath.Native.takeDirectory (fileName entry)
+        fullPath = baseDir </> fileName entry
+
+    extractDir entry =
+      createDirectoryIfMissing False (baseDir </> fileName entry)
+
+    saveLink entry links = seq (length name)
+                         $ seq (length name)
+                         $ link:links
       where
-        saveLink    = seq (length name)
-                    $ seq (length name)
-                    $ extractFiles (link:links) entries'
-          where
-            name    = fileName entry
-            target  = linkTarget entry
-            link    = (name, target)
+        name    = fileName entry
+        target  = linkTarget entry
+        link    = (name, target)
 
     extractLinks = mapM_ $ \(name, target) ->
-      let path      = dir </> name
+      let path      = baseDir </> name
        in copyFile (FilePath.Native.takeDirectory path </> target) path
 
 --