imported adelie-20060430
authorSergei Trofimovich <slyfox@inbox.ru>
Wed, 22 Apr 2009 19:42:37 +0000 (22 22:42 +0300)
committerSergei Trofimovich <slyfox@inbox.ru>
Wed, 22 Apr 2009 19:42:37 +0000 (22 22:42 +0300)
Signed-off-by: Sergei Trofimovich <slyfox@inbox.ru>
22 files changed:
Adelie/Colour.hs [new file with mode: 0644]
Adelie/CompareVersion.hs [new file with mode: 0644]
Adelie/Contents.hs [new file with mode: 0644]
Adelie/Depend.hs [new file with mode: 0644]
Adelie/ListEx.hs [new file with mode: 0644]
Adelie/Portage.hs [new file with mode: 0644]
Adelie/Pretty.hs [new file with mode: 0644]
Adelie/Provide.hs [new file with mode: 0644]
Adelie/QChangelog.hs [new file with mode: 0644]
Adelie/QCheck.hs [new file with mode: 0644]
Adelie/QDepend.hs [new file with mode: 0644]
Adelie/QHasUse.hs [new file with mode: 0644]
Adelie/QList.hs [new file with mode: 0644]
Adelie/QOwn.hs [new file with mode: 0644]
Adelie/QSize.hs [new file with mode: 0644]
Adelie/QUse.hs [new file with mode: 0644]
Adelie/QWant.hs [new file with mode: 0644]
Adelie/Use.hs [new file with mode: 0644]
Adelie/UseDesc.hs [new file with mode: 0644]
LICENCE.txt [new file with mode: 0644]
Main.hs [new file with mode: 0644]
Makefile [new file with mode: 0644]

diff --git a/Adelie/Colour.hs b/Adelie/Colour.hs
new file mode 100644 (file)
index 0000000..853e22c
--- /dev/null
@@ -0,0 +1,27 @@
+-- Colour.hs
+--
+-- Escape codes for colouring in output.
+
+module Adelie.Colour (
+    gray,
+    red,
+    green,
+    yellow,
+    blue,
+    magenta,
+    cyan,
+    white,
+    off,
+    off2
+) where
+
+gray    = putStr "\27[30;01m"
+red     = putStr "\27[31;01m"
+green   = putStr "\27[32;01m"
+yellow  = putStr "\27[33;01m"
+blue    = putStr "\27[34;01m"
+magenta = putStr "\27[35;01m"
+cyan    = putStr "\27[36;01m"
+white   = putStr "\27[37;01m"
+off     = putStr "\27[0m"
+off2    = putStrLn "\27[0m"
diff --git a/Adelie/CompareVersion.hs b/Adelie/CompareVersion.hs
new file mode 100644 (file)
index 0000000..91da3ba
--- /dev/null
@@ -0,0 +1,35 @@
+-- CompareVersion.hs
+--
+-- Version string comparitor, which handles numbers differently: 1.10 > 1.9.
+
+module Adelie.CompareVersion (compareVersion) where
+
+import Char (isDigit)
+
+import Adelie.ListEx (digitsToInt)
+
+----------------------------------------------------------------
+
+compareVersion :: String -> String -> Ordering
+compareVersion = cmpA
+
+cmpA :: String -> String -> Ordering
+cmpA a0 b0
+  | r == EQ   = cmpB as bs
+  | otherwise = r
+  where (a, as) = break (not.isDigit) a0
+        (b, bs) = break (not.isDigit) b0
+        r = compare (digitsToInt a) (digitsToInt b)
+
+cmpB :: String -> String -> Ordering
+cmpB [] []      = EQ
+cmpB ('*':_) _  = EQ
+cmpB _ ('*':_)  = EQ
+cmpB []  _      = LT
+cmpB  _ []      = GT
+cmpB a0 b0
+  | r == EQ   = cmpA as bs
+  | otherwise = r
+  where (a, as) = break isDigit a0
+        (b, bs) = break isDigit b0
+        r = compare a b
diff --git a/Adelie/Contents.hs b/Adelie/Contents.hs
new file mode 100644 (file)
index 0000000..f679a23
--- /dev/null
@@ -0,0 +1,86 @@
+-- Contents.hs
+--
+-- Module for parsing CONTENTS files, located in portageDB/category/package/.
+
+module Adelie.Contents (
+  Contents(..),
+
+  contentsFromCatName,
+  putContents,
+  putContentsLn,
+  readContents
+) where
+
+import Char (isDigit, isHexDigit, isSpace)
+import IO
+
+import Adelie.Colour
+import Adelie.ListEx
+import Adelie.Portage
+
+data Contents
+  = Dir String
+  | Obj String String Int
+  | Sym String String Int
+  deriving Show
+
+----------------------------------------------------------------
+
+contentsFromCatName :: (String, String) -> String
+contentsFromCatName (cat, name) = concatPath [portageDB,cat,name,"CONTENTS"]
+
+----------------------------------------------------------------
+
+readContents :: (Contents -> a -> IO (Bool, a)) -> FilePath -> a -> IO a
+readContents f fn a = do
+  fp <- openFile fn ReadMode
+  a' <- readContents' f fp a
+  hClose fp
+  return a'
+
+readContents' :: (Contents -> a -> IO (Bool, a)) -> Handle -> a -> IO a
+readContents' f fp a = do
+  eof <- hIsEOF fp
+  if eof
+    then return a
+    else do
+      ln <- hGetLine fp
+      (done, a') <- f (contentsParser ln) a
+      if done
+        then return a'
+        else readContents' f fp a'
+
+----------------------------------------------------------------
+
+putContents, putContentsLn :: Contents -> IO ()
+putContents   = putContents' off
+putContentsLn = putContents' off2
+
+putContents' :: IO () -> Contents -> IO ()
+putContents' f (Dir d)     = blue  >> putStr d >> f
+putContents' f (Obj o _ _) = white >> putStr o >> f
+putContents' f (Sym l t _) = cyan  >> putStr (l ++ " -> " ++ t) >> f
+
+----------------------------------------------------------------
+
+contentsParser :: String -> Contents
+contentsParser ('d':'i':'r':' ':dir) = (Dir dir)
+
+contentsParser ('o':'b':'j':' ':ln0) = (Obj obj md5 time)
+  where ln1 = dropWhile isSpace $ reverse ln0
+        (time', ln2) = break2 (not.isDigit) ln1
+        (md5', obj') = break2 (not.isHexDigit) ln2
+        obj  = reverse obj'
+        md5  = reverse md5'
+        time = digitsToInt (reverse time')
+
+contentsParser ('s':'y':'m':' ':ln0) = (Sym link target time)
+  where (link, ln1) = breakLink ln0
+        ln2 = reverse ln1
+        (time', target') = break2 (not.isDigit) ln2
+        target = reverse target'
+        time = digitsToInt (reverse time')
+
+breakLink (' ':'-':'>':' ':xs) = ([], xs)
+breakLink (x:xs) = (x:as, bs)
+  where (as, bs) = breakLink xs
diff --git a/Adelie/Depend.hs b/Adelie/Depend.hs
new file mode 100644 (file)
index 0000000..c31e0a6
--- /dev/null
@@ -0,0 +1,125 @@
+-- Depend.hs
+--
+-- Module for parsing DEPEND and RDEPEND files, located in
+-- portageDB/cateogry/package/.
+
+module Adelie.Depend (
+  Version,
+  Dependency(..),
+
+  dependFromCatName,
+  readDepend,
+  putDependency
+) where
+
+import Char (isSpace)
+import List (nub)
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Language
+import Text.ParserCombinators.Parsec.Token
+
+import Adelie.Portage
+
+type Version = String
+
+data Dependency
+  = GreaterEqual  String Version
+  | Equal         String Version
+  | Unstable      String Version
+  | NotInstalled  String
+  | Any           String
+    deriving (Eq, Show)
+
+----------------------------------------------------------------
+
+dependFromCatName :: (String, String) -> String
+dependFromCatName (cat, name) = concatPath [portageDB,cat,name,"RDEPEND"]
+
+----------------------------------------------------------------
+
+readDepend :: FilePath -> [String] -> IO [Dependency]
+readDepend fn iUse = do
+  r <- parseFromFile (dependParser iUse) fn
+  case r of
+    Left err -> putStr "Parse error at " >> print err >> error "Aborting"
+    Right x  -> return $ nub x
+
+----------------------------------------------------------------
+
+putDependency :: Dependency -> IO ()
+putDependency (GreaterEqual p v) = putStr $ ">=" ++ p ++ '-':v
+putDependency (Equal p v)        = putStr $ '=':p ++ '-':v
+putDependency (Unstable p v)     = putStr $ '~':p ++ '-':v
+putDependency (NotInstalled p)   = putStr $ '!':p
+putDependency (Any p)            = putStr p
+
+----------------------------------------------------------------
+
+dependParser :: [String] -> Parser [Dependency]
+dependParser iUse = do
+  skip <- spaces
+  packages <- many (dependParser' iUse)
+  return $ concat packages
+
+dependParser' :: [String] -> Parser [Dependency]
+dependParser' iUse = lexeme tp pp
+  where tp = makeTokenParser emptyDef
+        pp = parseOr iUse
+         <|> parsePackageOrUse iUse
+
+parseOr :: [String] -> Parser [Dependency]
+parseOr iUse = do { string "||"
+                  ; spaces
+                  ; parseBrackets iUse
+                  }
+
+parsePackageOrUse :: [String] -> Parser [Dependency]
+parsePackageOrUse iUse =
+  do { p <- parsePackageOrUseWord
+     ; do { char '?'        -- useFlag
+          ; spaces
+          ; r <- parseBrackets iUse
+          ; let filt | head p == '!' = not $ (tail p) `elem` iUse
+                     | otherwise     = p `elem` iUse
+          ; if filt
+              then return r
+              else return []
+          }
+   <|> return [toDependency p]
+     }
+
+parsePackageOrUseWord :: Parser String
+parsePackageOrUseWord = many1 (satisfy cond)
+  where
+    cond '?' = False
+    cond ')' = False
+    cond x = not $ isSpace x
+
+parseBrackets :: [String] -> Parser [Dependency]
+parseBrackets iUse = do { char '('
+                        ; spaces
+                        ; r <- manyTill (dependParser' iUse) (try (char ')'))
+                        ; return $ concat r
+                        }
+
+----------------------------------------------------------------
+
+breakVersion :: String -> (String, String)
+breakVersion str = (n, v)
+  where n = dropVersion str
+        v = drop (length n+1) str
+
+toDependency :: String -> Dependency
+
+toDependency ('>':'=':str) = (GreaterEqual n v)
+  where (n, v) = breakVersion str
+
+toDependency ('=':str) = (Equal n v)
+  where (n, v) = breakVersion str
+
+toDependency ('~':str) = (Unstable n v)
+  where (n, v) = breakVersion str
+
+toDependency ('!':n) = (NotInstalled n)
+
+toDependency n = (Any n)
diff --git a/Adelie/ListEx.hs b/Adelie/ListEx.hs
new file mode 100644 (file)
index 0000000..fd713d3
--- /dev/null
@@ -0,0 +1,32 @@
+-- ListEx.hs
+--
+-- Extra list functions.
+
+module Adelie.ListEx (
+  break2,
+  concatMapM,
+  digitsToInt,
+  dropTail,
+  pad
+) where
+
+import Char   (digitToInt)
+import Monad  (liftM)
+
+----------------------------------------------------------------
+
+break2 :: (a -> Bool) -> [a] -> ([a], [a])
+break2 f l = (h, drop 1 t)
+  where (h, t) = break f l
+
+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
+concatMapM f xs = liftM concat $ mapM f xs
+
+digitsToInt :: String -> Int
+digitsToInt = foldl (\ a b -> a*10 + digitToInt b) 0
+
+dropTail :: Int -> [a] -> [a]
+dropTail n s = take (length s-n) s
+
+pad :: Int -> a -> [a] -> [a]
+pad n a str = str ++ (replicate (n-length str) a)
diff --git a/Adelie/Portage.hs b/Adelie/Portage.hs
new file mode 100644 (file)
index 0000000..f41105d
--- /dev/null
@@ -0,0 +1,97 @@
+-- Portage.hs
+--
+-- Portage directories and file paths.
+
+module Adelie.Portage (
+  portageTree,
+  portageDB,
+  useDesc,
+  useDescPackage,
+
+  dropVersion,
+  concatPath,
+  fullnameFromCatName,
+  allInstalledPackages,
+  findInstalledPackages
+) where
+
+import Char       (isDigit)
+import Directory  (getDirectoryContents)
+import List       (intersperse, sort)
+import Monad      (liftM)
+
+import Adelie.ListEx
+
+portageTree :: String
+portageTree = "/usr/portage"
+
+-- Where portage's database is located.
+portageDB :: String
+portageDB = "/var/db/pkg"
+
+portageProfiles :: String
+portageProfiles = portageTree ++ "/profiles"
+
+-- Where the global use flag descriptions are, 'use.desc'.
+useDesc :: String
+useDesc = portageProfiles ++ "/use.desc"
+
+-- Where the package specific use flag descriptions are, 'use.local.desc'.
+useDescPackage :: String
+useDescPackage = portageProfiles ++ "/use.local.desc"
+
+----------------------------------------------------------------
+
+dropVersion :: String -> String
+dropVersion [] = []
+dropVersion ('-':x:xs)
+  | isDigit x = []
+  | otherwise = '-':x:(dropVersion xs)
+dropVersion (x:xs) = x:(dropVersion xs)
+
+concatPath :: [String] -> String
+concatPath = concat.intersperse "/"
+
+fullnameFromCatName :: (String, String) -> String
+fullnameFromCatName (cat, name) = cat ++ '/':name
+
+----------------------------------------------------------------
+
+allInstalledPackages :: IO [(String, String)]
+allInstalledPackages = do
+  cats <- liftM (sort.filter filterHidden) (getDirectoryContents portageDB)
+  concatMapM allInstalledPackagesInCategory cats
+
+allInstalledPackagesInCategory :: String -> IO [(String, String)]
+allInstalledPackagesInCategory cat = do
+  names <- liftM (sort.filter filterHidden) (getDirectoryContents path)
+  return $ map (\ a -> (cat, a)) names
+  where path = portageDB ++ '/':cat
+
+----------------------------------------------------------------
+
+findInstalledPackages :: [String] -> IO [(String, String)]
+findInstalledPackages names = concatMapM findInstPackages names
+
+findInstPackages :: String -> IO [(String, String)]
+findInstPackages name =
+  if null b
+    then findInstPackages' a
+    else findInstPackagesInCategory a b
+  where (a, b) = break2 (== '/') name
+
+findInstPackages' pack = do
+  cats  <- liftM (sort.filter filterHidden) (getDirectoryContents portageDB)
+  concatMapM (flip findInstPackagesInCategory pack) cats
+
+findInstPackagesInCategory cat pack = do
+  packs <- liftM (sort.filter cond) (getDirectoryContents (portageDB++'/':cat))
+  return (zip (repeat cat) packs)
+  where
+    cond ('.':_) = False
+    cond p = (pack == p) || (pack == dropVersion p)
+
+----------------------------------------------------------------
+
+filterHidden ('.':_) = False
+filterHidden _ = True
diff --git a/Adelie/Pretty.hs b/Adelie/Pretty.hs
new file mode 100644 (file)
index 0000000..bc4baec
--- /dev/null
@@ -0,0 +1,31 @@
+-- Pretty.hs
+--
+-- Colourful output.
+
+module Adelie.Pretty (
+  putCatName,
+  putCatNameLn,
+  putNum,
+  putNumLn
+) where
+
+import Adelie.Colour
+
+----------------------------------------------------------------
+
+putCatName, putCatNameLn :: (String, String) -> IO ()
+putCatName   = putCatName' off
+putCatNameLn = putCatName' off2
+
+putCatName' :: IO () -> (String, String) -> IO ()
+putCatName' f (c, n) =
+  yellow >> putStr c >> off >> putChar '/' >> yellow >> putStr n >> f
+
+----------------------------------------------------------------
+
+putNum, putNumLn :: Int -> IO ()
+putNum   = putNum' off
+putNumLn = putNum' off2
+
+putNum' :: IO () -> Int -> IO ()
+putNum' f n = cyan >> putStr (show n) >> f
diff --git a/Adelie/Provide.hs b/Adelie/Provide.hs
new file mode 100644 (file)
index 0000000..c6b3c93
--- /dev/null
@@ -0,0 +1,22 @@
+-- Provide.hs
+--
+-- Module for parsing PROVIDE files, located in portageDB/category/package/.
+
+module Adelie.Provide (
+  provideFromCatName,
+  readProvide
+) where
+
+import Monad (liftM)
+
+import Adelie.Portage
+
+----------------------------------------------------------------
+
+provideFromCatName :: (String, String) -> String
+provideFromCatName (cat,name) = concatPath [portageDB,cat,name,"PROVIDE"]
+
+----------------------------------------------------------------
+
+readProvide :: FilePath -> IO [String]
+readProvide fn = (liftM words (readFile fn)) `catch` (\ _ -> return [])
diff --git a/Adelie/QChangelog.hs b/Adelie/QChangelog.hs
new file mode 100644 (file)
index 0000000..baf54a3
--- /dev/null
@@ -0,0 +1,20 @@
+-- QChangelog.hs
+--
+-- Module to find the changelog of a package.
+
+module Adelie.QChangelog (
+  qChangelog
+) where
+
+import Adelie.Portage
+
+----------------------------------------------------------------
+
+qChangelog :: [String] -> IO ()
+qChangelog [] = return ()
+qChangelog args = mapM_ changelog =<< findInstalledPackages args
+
+changelog :: (String, String) -> IO ()
+changelog (cat, name) = do
+  putStrLn $ portageTree ++ fullname ++ "/ChangeLog"
+  where fullname = '/':cat ++ '/':(dropVersion name)
diff --git a/Adelie/QCheck.hs b/Adelie/QCheck.hs
new file mode 100644 (file)
index 0000000..2bbc2fa
--- /dev/null
@@ -0,0 +1,77 @@
+-- QMD5sum.hs
+--
+-- Check MD5sums and timestamps of installed packages.
+
+module Adelie.QCheck (qCheck) where
+
+import Char               (isHexDigit)
+import IO
+import Monad              (unless)
+import System
+import System.Process     (runProcess, waitForProcess)
+import System.Posix.Files (getFileStatus)
+import System.Posix.IO    (createPipe, fdToHandle)
+
+import Adelie.Colour
+import Adelie.Contents
+import Adelie.Portage
+import Adelie.Pretty
+
+-- Good, Bad
+type Count = (Int, Int)
+
+----------------------------------------------------------------
+
+qCheck :: [String] -> IO ()
+qCheck [] = return ()
+qCheck args = mapM_ check =<< findInstalledPackages args
+
+check :: (String, String) -> IO ()
+check catname = do
+  putStr "Checking " >> putCatNameLn catname
+  (g, b) <- readContents check' contents (0, 0)
+  putNum g >> putStr " out of " >> putNum (b+g) >> putStrLn " files good"
+  putChar '\n'
+  where contents = contentsFromCatName catname
+
+check' :: Contents -> Count -> IO (Bool, Count)
+
+check' (Dir _) (g, b) = return (False, (g+1, b))
+
+check' (Obj o m _) (g, b) = do
+  r <- try (getFileStatus o)
+  case r of
+    Left e -> do
+      red >> putStr "!!! " >> off >> putStr o >> putStrLn " does not exist"
+      return (False, (g, b+1))
+    Right stat -> do
+      (rd, wr) <- createPipeHandle
+      runMD5sum o (Just wr) >>= waitForProcess
+      ln <- hGetLine rd
+      hClose rd
+      hClose wr
+      if m == (takeWhile isHexDigit ln)
+        then return (False, (g+1, b))
+        else putMD5error o >> return (False, (g, b+1))
+
+check' (Sym _ _ _) (g, b) = return (False, (g+1, b))
+
+----------------------------------------------------------------
+
+createPipeHandle :: IO (Handle, Handle)
+createPipeHandle = do
+  (read, write) <- createPipe
+  hRead  <- fdToHandle read
+  hWrite <- fdToHandle write
+  return (hRead, hWrite)
+
+----------------------------------------------------------------
+
+runMD5sum f stdout = runProcess md5sum [f] Nothing Nothing stdin stdout stderr
+  where md5sum = "/usr/bin/md5sum"
+        stdin  = Nothing
+        stderr = Nothing
+
+putMD5error :: String -> IO ()
+putMD5error file =
+  red >> putStr "!!! " >> off >> putStrLn (file ++ " has incorrect md5sum")
diff --git a/Adelie/QDepend.hs b/Adelie/QDepend.hs
new file mode 100644 (file)
index 0000000..b26ac8a
--- /dev/null
@@ -0,0 +1,75 @@
+-- QDepend.hs
+--
+-- Module to list packages depending on an installed package.
+
+module Adelie.QDepend (qDepend) where
+
+import Adelie.Colour
+import Adelie.CompareVersion
+import Adelie.Depend
+import Adelie.ListEx
+import Adelie.Portage
+import Adelie.Pretty
+import Adelie.Provide
+import Adelie.Use
+
+----------------------------------------------------------------
+
+qDepend :: [String] -> IO ()
+qDepend [] = return ()
+qDepend args = qDepend' =<< findInstalledPackages args
+
+qDepend' :: [(String, String)] -> IO ()
+qDepend' catnames = do
+  allPacks <- allInstalledPackages
+  let allPacks2 = map fullnameFromCatName allPacks
+  mapM_ (dep allPacks2) catnames
+
+dep :: [String] -> (String, String) -> IO ()
+dep allPacks catname = do
+  putStr "Packages depending on " >> putCatNameLn catname
+  provide <- readProvide fnProvide
+  mapM_ (dep' (fullname:provide)) allPacks
+  putChar '\n'
+  where fullname = fullnameFromCatName catname
+        fnProvide = provideFromCatName catname
+
+dep' :: [String] -> String -> IO ()
+dep' provided fullname =
+  readUse fnIUse >>= readDepend fnDepend >>= puts fullname provided
+  where fnDepend = concatPath [portageDB,fullname,"RDEPEND"]
+        fnIUse = concatPath [portageDB,fullname,"USE"]
+
+puts :: String -> [String] -> [Dependency] -> IO ()
+puts str provided iWant = mapM_ print perms
+  where perms = [ (p, w) | p <- provided, w <- iWant, w `satisfiedBy` p ]
+        print (p, w) =
+          white >> putStr (pad 32 ' ' str) >> off >>
+          putStr "\t( " >> putDependency w >> putStrLn " )"
+
+-------------------------------------------------------------
+
+breakVersion :: String -> (String, String)
+breakVersion str = (n, v)
+  where n = dropVersion str
+        v = drop (length n+1) str
+
+satisfiedBy :: Dependency -> String -> Bool
+
+(GreaterEqual wantName wantVer) `satisfiedBy` provided =
+  (wantName == provName) && (compareVersion provVer wantVer) /= LT
+  where (provName, provVer) = breakVersion provided
+
+(Equal wantName wantVer) `satisfiedBy` provided = 
+  (wantName == provName) && (compareVersion provVer wantVer) == EQ
+  where (provName, provVer) = breakVersion provided
+
+(Unstable wantName wantVer) `satisfiedBy` provided =
+  (wantName == provName) && (compareVersion provVer wantVer) == EQ
+  where (provName, provVer) = breakVersion provided
+
+(NotInstalled _) `satisfiedBy` _ = False
+
+(Any wantName) `satisfiedBy` provided =
+  wantName == provName
+  where provName = dropVersion provided
diff --git a/Adelie/QHasUse.hs b/Adelie/QHasUse.hs
new file mode 100644 (file)
index 0000000..af6cd4f
--- /dev/null
@@ -0,0 +1,38 @@
+-- QHasUse.hs
+--
+-- Module to list all installed packages with a particular use flag.
+
+module Adelie.QHasUse (qHasUse) where
+
+import Monad (when)
+
+import Adelie.Colour
+import Adelie.Portage
+import Adelie.Pretty
+import Adelie.Use
+
+----------------------------------------------------------------
+
+qHasUse :: [String] -> IO ()
+qHasUse [] = return ()
+qHasUse args = qHasUse' args =<< allInstalledPackages 
+
+qHasUse' :: [String] -> [(String, String)] -> IO ()
+qHasUse' uses catnames = mapM_ (hasUse catnames) uses
+
+hasUse :: [(String, String)] -> String -> IO ()
+hasUse catnames use = do
+  putStr "Packages installed with " >> putUse use >> putStrLn " USE flag"
+  mapM_ (flip hasUse' use) catnames
+  putChar '\n'
+
+hasUse' :: (String, String) -> String -> IO ()
+hasUse' catname use = do
+  iUse <- readIUse fnIUse
+  when (use `elem` iUse) (putCatNameLn catname)
+  where fnIUse = iUseFromCatName catname
+
+----------------------------------------------------------------
+
+putUse :: String -> IO ()
+putUse u = blue >> putStr u >> off
diff --git a/Adelie/QList.hs b/Adelie/QList.hs
new file mode 100644 (file)
index 0000000..156223c
--- /dev/null
@@ -0,0 +1,54 @@
+-- QList.hs
+--
+-- Module to list the contents of an installed package.
+
+module Adelie.QList (
+  ListTypes(..),
+
+  qList
+) where
+
+import Adelie.Contents
+import Adelie.Portage
+import Adelie.Pretty
+
+data ListTypes
+  = ListDirs
+  | ListFiles
+  | ListLinks
+  | ListAll
+  deriving Eq
+
+---------------------------------------------------------------- 
+
+qList :: ListTypes -> [String] -> IO ()
+qList _ [] = return ()
+qList types args = mapM_ (list puts) =<< findInstalledPackages args
+  where
+    puts = case types of
+      ListDirs  -> putsD
+      ListFiles -> putsF
+      ListLinks -> putsL
+      otherwise -> putsA
+
+list puts catname = do
+  putStr "Contents of " >> putCatNameLn catname
+  readContents puts contents ()
+  putChar '\n'
+  where contents = contentsFromCatName catname
+
+----------------------------------------------------------------
+
+putsA, putsD, putsF, putsL :: Contents -> () -> IO (Bool, ())
+
+putsA (Obj o _ _) _ = putStrLn o      >> return (False, ())
+putsA c _           = putContentsLn c >> return (False, ())
+
+putsD c@(Dir d) _   = putContentsLn c >> return (False, ())
+putsD _ _           = return (False, ())
+
+putsF (Obj o _ _) _ = putStrLn o >> return (False, ())
+putsF _ _           = return (False, ())
+
+putsL c@(Sym _ _ _)_= putContentsLn c >> return (False, ())
+putsL _ _           = return (False, ())
diff --git a/Adelie/QOwn.hs b/Adelie/QOwn.hs
new file mode 100644 (file)
index 0000000..69931d4
--- /dev/null
@@ -0,0 +1,80 @@
+-- QOwn.hs
+--
+-- Module to query who owns a particular file.
+
+module Adelie.QOwn (
+  qOwn,
+  qOwnRegex
+) where
+
+import List       (delete)
+import Monad      (foldM, when)
+import Text.Regex (Regex, matchRegex, mkRegex)
+
+import Adelie.Colour
+import Adelie.Contents
+import Adelie.Portage
+import Adelie.Pretty
+
+----------------------------------------------------------------
+
+qOwn :: [String] -> IO ()
+qOwn [] = return ()
+qOwn args = do
+  foldM qOwn' args =<< allInstalledPackages
+  putChar '\n'
+
+qOwn' :: [String] -> (String, String) -> IO [String]
+qOwn' [] _ = return []
+qOwn' files catname = readContents (puts catname) contents files
+  where contents = contentsFromCatName catname
+
+----------------------------------------------------------------
+
+puts :: (String, String) -> Contents -> [String] -> IO (Bool, [String])
+puts catname c fs =
+  if c `contentsElem` fs
+    then do
+      let fs' = deleteContent c fs
+      putCatName catname >> putStr " (" >> putContents c >> putStrLn ")"
+      return (fs' == [], fs')
+    else
+      return (False, fs)
+
+contentsElem :: Contents -> [String] -> Bool
+(Dir d)     `contentsElem` fs = d `elem` fs
+(Obj o _ _) `contentsElem` fs = o `elem` fs
+(Sym l _ _) `contentsElem` fs = l `elem` fs
+
+-- Only remove objects from the list.
+deleteContent :: Contents -> [String] -> [String]
+deleteContent (Obj o _ _) fs = delete o fs
+deleteContent _ fs = fs
+
+----------------------------------------------------------------
+
+qOwnRegex :: [String] -> IO ()
+qOwnRegex args = mapM_ (qOwnRegex' pats) =<< allInstalledPackages
+  where pats = map mkRegex args
+
+qOwnRegex' :: [Regex] -> (String, String) -> IO ()
+qOwnRegex' pats catname = readContents (putsRegex catname pats) contents ()
+  where contents = contentsFromCatName catname
+
+putsRegex :: (String, String) -> [Regex] -> Contents -> () -> IO (Bool, ())
+putsRegex catname pats c _ = do
+  when (c `regexElem` pats) match
+  return (False, ())
+  where match = putCatName catname >> putStr " (" >> putContents c>>putStrLn ")"
+
+regexElem :: Contents -> [Regex] -> Bool
+(Dir d)     `regexElem` pats = mapMaybeOnce (flip matchRegex d) pats
+(Obj o _ _) `regexElem` pats = mapMaybeOnce (flip matchRegex o) pats
+(Sym l _ _) `regexElem` pats = mapMaybeOnce (flip matchRegex l) pats
+
+mapMaybeOnce :: (a -> Maybe b) -> [a] -> Bool
+mapMaybeOnce _ [] = False
+mapMaybeOnce f (x:xs) =
+  case f x of 
+    Just a  -> True
+    Nothing -> mapMaybeOnce f xs
diff --git a/Adelie/QSize.hs b/Adelie/QSize.hs
new file mode 100644 (file)
index 0000000..0f5d6c2
--- /dev/null
@@ -0,0 +1,62 @@
+-- QSize.hs
+--
+-- Check the disk usage of an installed packaged.
+
+module Adelie.QSize (qSize) where
+
+import Directory            (doesDirectoryExist)
+import IO                   (isDoesNotExistError, try)
+import Monad                (mapM_, when)
+import System.Posix.Files   (fileSize, getFileStatus)
+import System.Posix.Types   (FileOffset)
+
+import Adelie.Colour
+import Adelie.Contents
+import Adelie.Portage
+import Adelie.Pretty
+
+-- Size, Dir, Obj, Sym, Inaccessible
+type Count = (FileOffset, Int, Int, Int, Int)
+
+----------------------------------------------------------------
+
+qSize :: [String] -> IO ()
+qSize [] = return ()
+qSize args = mapM_ size =<< findInstalledPackages args
+
+size :: (String, String) -> IO ()
+size catname = do
+  putStr "Size of " >> putCatNameLn catname
+  (size, dir, obj, sym, err) <- readContents count contents (0, 0, 0, 0, 0)
+  putStr "    Directories: " >> putNumLn dir
+  putStr "          Files: " >> putNumLn obj
+
+  when (sym > 0) (putStr "          Links: " >> putNumLn sym)
+  when (err > 0) (putStr "   Inaccessible: " >> putNumLn err)
+
+  putStr "     Total size: " >> putSizeLn size
+  putChar '\n'
+  where contents = contentsFromCatName catname
+
+----------------------------------------------------------------
+
+count :: Contents -> Count -> IO (Bool, Count)
+
+count c@(Dir d) (s,w,x,y,z) = do
+  r <- doesDirectoryExist d
+  if r
+    then return (False, (s,w+1,x,y,z))
+    else return (False, (s,w,x,y,z+1)) 
+
+count c@(Obj o _ _) (s,w,x,y,z) = do
+  r <- try (getFileStatus o)
+  case r of
+    Left err -> return (False, (s, w, x, y, z+1))
+    Right st -> return (False, (s+fileSize st, w, x+1, y, z))
+
+count (Sym _ _ _) (s,w,x,y,z) = return (False, (s,w,x,y+1,z))
+
+----------------------------------------------------------------
+
+putSizeLn :: FileOffset -> IO ()
+putSizeLn n = cyan >> putStr (show (n `div` 1024)) >> putStr " kb" >> off2
diff --git a/Adelie/QUse.hs b/Adelie/QUse.hs
new file mode 100644 (file)
index 0000000..2b2244d
--- /dev/null
@@ -0,0 +1,76 @@
+-- QUse.hs
+--
+-- Module to describe the use flags of an installed package.
+
+module Adelie.QUse (qUse) where
+
+import Data.HashTable as HashTable
+import Monad (mapM_, unless)
+
+import Adelie.Colour
+import Adelie.ListEx
+import Adelie.Portage
+import Adelie.Pretty
+import Adelie.Use
+import Adelie.UseDesc
+
+----------------------------------------------------------------
+
+qUse :: [String] -> IO ()
+qUse [] = return ()
+qUse args = qUse' =<< findInstalledPackages args
+
+qUse' :: [(String, String)] -> IO ()
+qUse' [] = return ()
+qUse' catnames = do
+  useDesc <- readUseDesc
+  useDescPackage <- readUseDescPackage min max
+  mapM_ (use useDesc useDescPackage) catnames
+  where min = dropVersion $ fullnameFromCatName $ minimum catnames
+        max = dropVersion $ fullnameFromCatName $ maximum catnames
+
+use :: UseDescriptions -> UseDescriptions -> (String, String) -> IO ()
+use useDesc useDescPackage catname = do
+  iUse <- readIUse fnIUse
+  pUse <- readUse  fnPUse
+  let len = maximum $ map length iUse
+  use' catname len useDesc useDescPackage iUse pUse
+  where fnIUse = iUseFromCatName catname
+        fnPUse = useFromCatName catname
+
+use' :: (String, String) -> Int -> UseDescriptions -> UseDescriptions ->
+        [String] -> [String] -> IO ()
+
+use' catname _ _ _ [] _ = putStr "No USE flags for " >> putCatNameLn catname
+use' catname len useDesc useDescPackage iUse pUse = do
+  putStr "USE flags for " >> putCatNameLn catname
+  mapM_ (format len useDesc useDescPackage pUse) iUse
+  putChar '\n'
+
+----------------------------------------------------------------
+
+format :: Int -> UseDescriptions -> UseDescriptions ->
+          [String] -> String -> IO ()
+
+format len useDesc useDescPackage pUse iUse =
+  inst >> putStr (pad len ' ' iUse) >> off >> putStr " : " >> desc
+  where
+    inst = if iUse `elem` pUse
+            then putStr " + " >> red
+            else putStr "   " >> blue
+
+    desc = do
+      end <- desc' useDescPackage
+      unless end (do
+        end <- desc' useDesc
+        unless end (putStrLn "<< no description >>"))
+
+    desc' descs = do
+      r <- HashTable.lookup descs iUse 
+      case r of
+        Just d  -> puts d >> return True
+        Nothing -> return False
+
+puts :: String -> IO ()
+puts d@('!':'!':_) = red >> putStr d >> off2
+puts d = putStrLn d
diff --git a/Adelie/QWant.hs b/Adelie/QWant.hs
new file mode 100644 (file)
index 0000000..2832d4b
--- /dev/null
@@ -0,0 +1,27 @@
+-- QWant.hs
+--
+-- List the direct dependencies of a file.
+
+module Adelie.QWant (qWant) where
+
+import Adelie.Depend
+import Adelie.Portage
+import Adelie.Pretty
+import Adelie.Use
+
+-------------------------------------------------------------
+
+qWant :: [String] -> IO ()
+qWant []   = return ()
+qWant args = mapM_ qWant' =<< findInstalledPackages args
+
+qWant' :: (String, String) -> IO ()
+qWant' catname = do
+  putStr "Dependencies for " >> putCatNameLn catname
+  readUse fnIUse >>= readDepend fnDepend >>= mapM_ puts
+  putChar '\n'
+  where fnDepend = dependFromCatName catname
+        fnIUse = useFromCatName catname
+
+puts :: Dependency -> IO ()
+puts a = putDependency a >> putChar '\n'
diff --git a/Adelie/Use.hs b/Adelie/Use.hs
new file mode 100644 (file)
index 0000000..496d95e
--- /dev/null
@@ -0,0 +1,34 @@
+-- Use.hs
+--
+-- Module for parsing USE and IUSE, files, located in
+-- portageDB/category/package/.
+
+module Adelie.Use (
+  useFromCatName,
+  iUseFromCatName,
+  readUse,
+  readIUse
+) where
+
+import List   (nub, sort)
+import Monad  (liftM)
+
+import Adelie.Portage
+
+----------------------------------------------------------------
+
+useFromCatName :: (String, String) -> String
+useFromCatName (cat, name) = concatPath [portageDB,cat,name,"USE"]
+
+iUseFromCatName :: (String, String) -> String
+iUseFromCatName (cat, name) = concatPath [portageDB,cat,name,"IUSE"]
+
+----------------------------------------------------------------
+
+readUse :: FilePath -> IO [String]
+readUse fn = liftM words (readFile fn)
+
+-- IUSE files sometimes have duplicate USE flags.  I am not sure if it is the
+-- intended behaviour, but I filter them out.
+readIUse :: FilePath -> IO [String]
+readIUse fn = liftM (nub.sort.words) (readFile fn)
diff --git a/Adelie/UseDesc.hs b/Adelie/UseDesc.hs
new file mode 100644 (file)
index 0000000..e64a04e
--- /dev/null
@@ -0,0 +1,110 @@
+-- UseDesc.hs
+--
+-- Module for parsing portageProfile/use.desc and use.local.desc files.
+
+module Adelie.UseDesc (
+  UseDescriptions,
+  readUseDesc,
+  readUseDescPackage
+) where
+
+import Data.HashTable as HashTable
+import Text.ParserCombinators.Parsec
+
+import Adelie.Portage
+
+type UseDesc = (String, String)
+type UseDescriptions = HashTable String String
+
+----------------------------------------------------------------
+
+genReadDesc :: Parser [UseDesc] -> String -> IO [UseDesc]
+genReadDesc p fn = do
+  r <- parseFromFile p fn
+  case r of
+    Left err -> putStr "Parse error at " >> print err >> error "Aborting"
+    Right x  -> return x
+
+----------------------------------------------------------------
+
+readUseDesc :: IO UseDescriptions
+readUseDesc = genReadDesc useParser useDesc >>= HashTable.fromList hashString
+
+useParser :: Parser [UseDesc]
+useParser = useParser' `sepEndBy` newline
+
+useParser' :: Parser UseDesc
+useParser' = parseComment useParser'
+         <|> parseUse
+
+----------------------------------------------------------------
+
+readUseDescPackage :: String -> String -> IO UseDescriptions
+readUseDescPackage start end = 
+  genReadDesc (useParser2 start end) useDescPackage >>=
+  HashTable.fromList hashString
+
+useParser2 :: String -> String -> Parser [UseDesc]
+useParser2 start end = (useParser2' start end) `sepEndBy` newline
+
+useParser2' :: String -> String -> Parser UseDesc
+useParser2' start end =
+      parseComment (useParser2' start end)
+  <|> do { readname <- many1 (satisfy notColon)
+         ; case mid start readname end of
+             LT -> skipMany (satisfy notNewline) >> useParser2' start end
+             GT -> return ("","")
+             otherise -> char ':' >> parseUse
+         }
+
+----------------------------------------------------------------
+
+-- In Haskell, vim-core > vim
+-- In sort,    vim-core < vim
+-- Work around it.
+myCompare :: String -> String -> Ordering
+myCompare [] [] = EQ
+myCompare  _ [] = LT
+myCompare []  _ = GT
+myCompare (a:as) (b:bs) =
+  if r == EQ
+    then myCompare as bs 
+    else r
+  where r = compare a b
+
+mid :: String -> String -> String -> Ordering
+mid l m r
+  | myCompare l m == GT = LT
+  | myCompare m r == GT = GT
+  | otherwise = EQ
+
+----------------------------------------------------------------
+
+parseUse :: Parser UseDesc
+parseUse = do { use <- useFlag
+              ; spaces
+              ; string "- "
+              ; desc <- description
+              ; return (use, desc)
+              }
+
+parseComment :: Parser UseDesc -> Parser UseDesc
+parseComment cont = do { char '#'
+                       ; skipMany (satisfy notNewline)
+                       ; cont
+                       }
+                <|> do { space
+                       ; cont
+                       }
+
+useFlag :: Parser String
+useFlag = many1 (satisfy (/= ' '))
+
+description :: Parser String
+description = many1 (satisfy notNewline)
+
+notColon, notNewline :: Char -> Bool
+notColon ':'    = False
+notColon _      = True
+notNewline '\n' = False
+notNewline _    = True
diff --git a/LICENCE.txt b/LICENCE.txt
new file mode 100644 (file)
index 0000000..1f22422
--- /dev/null
@@ -0,0 +1,23 @@
+
+  Copyright (C) 2006 David Wang
+
+  This software is provided 'as-is', without any express or implied
+  warranty.  In no event will the authors be held liable for any damages
+  arising from the use of this software.
+
+  Permission is granted to anyone to use this software for any purpose,
+  including commercial applications, and to alter it and redistribute it
+  freely, subject to the following restrictions:
+
+  1. The origin of this software must not be misrepresented; you must not
+     claim that you wrote the original software. If you use this software
+     in a product, an acknowledgment in the product documentation would be
+     appreciated but is not required.
+
+  2. Altered source versions must be plainly marked as such, and must not
+     be misrepresented as being the original software.
+
+  3. This notice may not be removed or altered from any source distribution.
+
+
+  [For informational purposes, this is the zlib licence.]
diff --git a/Main.hs b/Main.hs
new file mode 100644 (file)
index 0000000..7c0a45d
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,92 @@
+#!/usr/bin/runhugs -98
+-- Main.hs
+--
+-- Adelie is a collection of scripts to querying portage packages. 
+
+module Main (main) where
+
+import System
+
+import Adelie.Colour
+import Adelie.QChangelog
+import Adelie.QCheck
+import Adelie.QDepend
+import Adelie.QHasUse
+import Adelie.QList
+import Adelie.QOwn
+import Adelie.QSize
+import Adelie.QUse
+import Adelie.QWant
+
+data Command
+  = Short String String ([String] -> IO ())
+
+logCommands = [
+  (Short "c"  "find the changelog of a package"     qChangelog)
+  ]
+
+listCommands = [
+  (Short "f"  "list the contents of a package"      (qList ListAll)),
+  (Short "fd" "list the directories in a package"   (qList ListDirs)),
+  (Short "ff" "list the files in a package"         (qList ListFiles)),
+  (Short "fl" "list the links in a package"         (qList ListLinks))
+  ]
+
+ownCommands = [
+  (Short "b"  "find the package(s) owning a file"                   qOwn),
+  (Short "bp" "find the package(s) owning a file with regexp"       qOwnRegex),
+  (Short "s"  "find the size of files in a package"                 qSize),
+  (Short "k"  "check MD5sums and timestamps of a package"           qCheck)
+  ]
+
+dependCommands = [
+  (Short "d"  "list packages directly depending on this package"    qDepend),
+  (Short "dd" "list direct dependencies of a package"               qWant)
+  ]
+
+useCommands = [
+  (Short "u"  "describe a package's USE flags"      qUse),
+  (Short "h"  "list all packages with a USE flag"   qHasUse)
+  ]
+
+allCommands =
+  -- All packages
+  logCommands ++ 
+  -- Installed packages only
+  listCommands ++ ownCommands ++ dependCommands ++ useCommands
+
+----------------------------------------------------------------
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [] -> usage
+    (cmd:cargs) -> main' cmd cargs allCommands
+
+main' :: String -> [String] -> [Command] -> IO ()
+main' _ _ [] = usage
+main' command args ((Short cmd _ f):xs)
+  | command == cmd  = f args
+  | otherwise       = main' command args xs
+
+----------------------------------------------------------------
+
+usage :: IO ()
+usage = do
+  putStrLn "Adelie v0.1\n"
+  putStrLn "Usage: adelie <command> <arguments>\n"
+
+  cyan >> putStr "Commands for Installed Packages:" >> off2
+  mapM_ putCommand logCommands; nl
+  mapM_ putCommand listCommands; nl
+  mapM_ putCommand ownCommands; nl
+  mapM_ putCommand dependCommands; nl
+  mapM_ putCommand useCommands; nl
+
+putCommand :: Command -> IO ()
+putCommand (Short cmd desc _) =
+  putStr "    " >> green >> putStr cmd >> off >> tab >> putStrLn desc
+
+tab = putChar '\t'
+nl  = putChar '\n'
diff --git a/Makefile b/Makefile
new file mode 100644 (file)
index 0000000..e8e12a2
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,13 @@
+HC  := ghc
+HCFLAGS := -O -odirobj -package text -fglasgow-exts
+PROG := adelie
+
+all : $(PROG)
+
+.PHONY: adelie
+adelie : Main.hs
+       $(HC) $(HCFLAGS) --make -o $@ $<
+
+.PHONY : strip
+strip :
+       strip $(PROG)