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 ( 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 get_test :: [DarcsFlag] -> IO (IO ExitCode)
   61 get_test opts =
   62  let putInfo s = when (not $ Quiet `elem` opts) $ putStr s
   63  in do
   64  testline <- get_prefval "test"
   65  return $
   66    case testline of
   67    Nothing -> return ExitSuccess
   68    Just testcode -> do
   69      putInfo "Running test...\n"
   70      ec <- system testcode
   71      if ec == ExitSuccess
   72        then putInfo "Test ran successfully.\n"
   73        else putInfo "Test failed!\n"
   74      return ec
   75 
   76 run_posthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
   77 run_posthook opts repodir = do ph <- get_posthook opts
   78                                withCurrentDirectory repodir $ run_hook opts "Posthook" ph
   79 
   80 get_posthook :: [DarcsFlag] -> IO (Maybe String)
   81 get_posthook opts = case get_posthook_cmd opts of
   82                     Nothing -> return Nothing
   83                     Just command ->
   84                        if AskPosthook `elem` opts
   85                        then do yorn <- askUser ("\nThe following command is set to execute.\n"++
   86                                                 "Execute the following command now (yes or no)?\n"++
   87                                                 command++"\n")
   88                                case yorn of ('y':_) -> return $ Just command
   89                                             _ -> do putStrLn "Posthook cancelled..."
   90                                                     return Nothing
   91                        else return $ Just command
   92 
   93 run_prehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
   94 run_prehook opts repodir = do ph <- get_prehook opts
   95                               withCurrentDirectory repodir $ run_hook opts "Prehook" ph
   96 
   97 get_prehook :: [DarcsFlag] -> IO (Maybe String)
   98 get_prehook opts = case get_prehook_cmd opts of
   99                    Nothing -> return Nothing
  100                    Just command ->
  101                        if AskPrehook `elem` opts
  102                        then do yorn <- askUser ("\nThe following command is set to execute.\n"++
  103                                                 "Execute the following command now (yes or no)?\n"++
  104                                                 command++"\n")
  105                                case yorn of ('y':_) -> return $ Just command
  106                                             _ -> do putStrLn "Prehook cancelled..."
  107                                                     return Nothing
  108                        else return $ Just command
  109 
  110 run_hook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode
  111 run_hook _ _ Nothing = return ExitSuccess
  112 run_hook opts cname (Just command) =
  113     do ec <- system command
  114        when (Quiet `notElem` opts) $
  115          if ec == ExitSuccess
  116          then putStrLn $ cname++" ran successfully."
  117          else hPutStrLn stderr $ cname++" failed!"
  118        return ec
  119 \end{code}