src/Darcs/Test.lhs

   1 %  Copyright (C) 2002-2005 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \begin{code}
  19 module Darcs.Test ( run_test, get_test,
  20                     run_posthook, run_prehook )
  21 where
  22 import Darcs.RepoPath ( AbsolutePath )
  23 import Darcs.Utils ( withCurrentDirectory )
  24 import System.Exit ( ExitCode(..) )
  25 import System.Cmd ( system )
  26 import Control.Monad ( when )
  27
  28 import Darcs.Arguments ( DarcsFlag( Quiet,
  29                                     AskPosthook, AskPrehook ),
  30                         get_posthook_cmd, get_prehook_cmd )
  31 import Darcs.Repository.Prefs ( get_prefval )
  32 import Darcs.Utils ( askUser )
  33 import System.IO ( hPutStrLn, stderr )
  34 \end{code}
  35
  36 If you like, you can configure your repository to be able to run a test
  37 suite of some sort.  You can do this by using ``setpref'' to set the
  38 ``test'' value to be a command to run, e.g.
  39 \begin{verbatim}
  40 % darcs setpref test "sh configure && make && make test"
  41 \end{verbatim}
  42 Or, if you want to define a test specific to one copy of the repository,
  43 you could do this by editing the file \verb!_darcs/prefs/prefs!.
  44
  45 \begin{options}
  46 --leave-test-directory, --remove-test-directory
  47 \end{options}
  48
  49 Normally darcs deletes the directory in which the test was run afterwards.
  50 Sometimes (especially when the test fails) you'd prefer to be able to be
  51 able to examine the test directory after the test is run.  You can do this
  52 by specifying the \verb!--leave-test-directory! flag.  Alas, there is no
  53 way to make darcs leave the test directory only if the test fails.  The
  54 opposite of \verb!--leave-test-directory! is
  55 \verb!--remove-test-directory!, which could come in handy if you choose to
  56 make \verb!--leave-test-directory! the default (see
  57 section~\ref{defaults}).
  58
  59 \begin{code}
  60 run_test :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
  61 run_test opts testdir = do test <- get_test opts
  62                            withCurrentDirectory testdir test
  63
  64 get_test :: [DarcsFlag] -> IO (IO ExitCode)
  65 get_test opts =
  66  let putInfo s = when (not $ Quiet `elem` opts) $ putStr s
  67  in do
  68  testline <- get_prefval "test"
  69  return $
  70    case testline of
  71    Nothing -> return ExitSuccess
  72    Just testcode -> do
  73      putInfo "Running test...\n"
  74      ec <- system testcode
  75      if ec == ExitSuccess
  76        then putInfo "Test ran successfully.\n"
  77        else putInfo "Test failed!\n"
  78      return ec
  79 \end{code}
  80
  81 \begin{code}
  82 run_posthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
  83 run_posthook opts repodir = do ph <- get_posthook opts
  84                                withCurrentDirectory repodir $ run_hook opts "Posthook" ph
  85
  86 get_posthook :: [DarcsFlag] -> IO (Maybe String)
  87 get_posthook opts = case get_posthook_cmd opts of
  88                     Nothing -> return Nothing
  89                     Just command ->
  90                        if AskPosthook `elem` opts
  91                        then do yorn <- askUser ("\nThe following command is set to execute.\n"++
  92                                                 "Execute the following command now (yes or no)?\n"++
  93                                                 command++"\n")
  94                                case yorn of ('y':_) -> return $ Just command
  95                                             _ -> do putStrLn "Posthook cancelled..."
  96                                                     return Nothing
  97                        else return $ Just command
  98
  99 run_prehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
 100 run_prehook opts repodir = do ph <- get_prehook opts
 101                               withCurrentDirectory repodir $ run_hook opts "Prehook" ph
 102
 103 get_prehook :: [DarcsFlag] -> IO (Maybe String)
 104 get_prehook opts = case get_prehook_cmd opts of
 105                    Nothing -> return Nothing
 106                    Just command ->
 107                        if AskPrehook `elem` opts
 108                        then do yorn <- askUser ("\nThe following command is set to execute.\n"++
 109                                                 "Execute the following command now (yes or no)?\n"++
 110                                                 command++"\n")
 111                                case yorn of ('y':_) -> return $ Just command
 112                                             _ -> do putStrLn "Prehook cancelled..."
 113                                                     return Nothing
 114                        else return $ Just command
 115
 116 run_hook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode
 117 run_hook _ _ Nothing = return ExitSuccess
 118 run_hook opts cname (Just command) =
 119     do ec <- system command
 120        when (Quiet `notElem` opts) $
 121          if ec == ExitSuccess
 122          then putStrLn $ cname++" ran successfully."
 123          else hPutStrLn stderr $ cname++" failed!"
 124        return ec
 125 \end{code}