aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-02-14 15:02:42 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-02-14 15:02:42 -0400
commitb9c249d46e582bf52b771368cfe9d8d455c11f9f (patch)
treed80ac8add3a7c560a8ec8cb148d6e1ae2effbe9e
parentcc13dd82c5cd7647f911ed6be1e58694f7edee31 (diff)
Work around problem with concurrent-output when in a non-unicode locale by avoiding use of it in such a locale.
Instead -J will behave as if it was built without concurrent-output support in this situation. Ie, it will be mostly quiet, except when there's an error. Note that it's not a problem for a filename to contain invalid utf-8 when in a utf-8 locale. That is handled ok by concurrent-output. It's only displaying unicode characters in a non-unicode locale that doesn't work.
-rw-r--r--CmdLine/Action.hs14
-rw-r--r--Messages.hs2
-rw-r--r--Messages/Concurrent.hs73
-rw-r--r--Messages/Internal.hs4
-rw-r--r--Messages/Progress.hs24
-rw-r--r--Types/Messages.hs2
-rw-r--r--debian/changelog3
-rw-r--r--doc/bugs/Unable_to_parallel_fsck.mdwn5
8 files changed, 82 insertions, 45 deletions
diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index ec31c32f0..c1dd12b51 100644
--- a/CmdLine/Action.hs
+++ b/CmdLine/Action.hs
@@ -53,7 +53,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
commandAction :: CommandStart -> Annex ()
commandAction a = withOutputType go
where
- go (ConcurrentOutput n) = do
+ go o@(ConcurrentOutput n _) = do
ws <- Annex.getState Annex.workers
(st, ws') <- if null ws
then do
@@ -63,7 +63,7 @@ commandAction a = withOutputType go
l <- liftIO $ drainTo (n-1) ws
findFreeSlot l
w <- liftIO $ async
- $ snd <$> Annex.run st (inOwnConsoleRegion run)
+ $ snd <$> Annex.run st (inOwnConsoleRegion o run)
Annex.changeState $ \s -> s { Annex.workers = Right w:ws' }
go _ = run
run = void $ includeCommandAction a
@@ -155,9 +155,13 @@ allowConcurrentOutput :: Annex a -> Annex a
allowConcurrentOutput a = go =<< Annex.getState Annex.concurrentjobs
where
go Nothing = a
- go (Just n) = Regions.displayConsoleRegions $
- bracket_ (setup n) cleanup a
- setup = Annex.setOutput . ConcurrentOutput
+ go (Just n) = ifM (liftIO concurrentOutputSupported)
+ ( Regions.displayConsoleRegions $
+ goconcurrent (ConcurrentOutput n True)
+ , goconcurrent (ConcurrentOutput n False)
+ )
+ goconcurrent o = bracket_ (setup o) cleanup a
+ setup = Annex.setOutput
cleanup = do
finishCommandActions
Annex.setOutput NormalOutput
diff --git a/Messages.hs b/Messages.hs
index cec0cb8a3..8d8f916ce 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -212,7 +212,7 @@ commandProgressDisabled = withOutputType $ \t -> return $ case t of
QuietOutput -> True
JSONOutput -> True
NormalOutput -> False
- ConcurrentOutput _ -> True
+ ConcurrentOutput {} -> True
{- Use to show a message that is displayed implicitly, and so might be
- disabled when running a certian command that needs more control over its
diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs
index a4710e310..ee81109f1 100644
--- a/Messages/Concurrent.hs
+++ b/Messages/Concurrent.hs
@@ -1,13 +1,12 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
{- git-annex output messages, including concurrent output to display regions
-
- - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Messages.Concurrent where
@@ -20,6 +19,7 @@ import qualified System.Console.Concurrent as Console
import qualified System.Console.Regions as Regions
import Control.Concurrent.STM
import qualified Data.Text as T
+import GHC.IO.Encoding
#endif
{- Outputs a message in a concurrency safe way.
@@ -29,9 +29,14 @@ import qualified Data.Text as T
- When built without concurrent-output support, the fallback action is run
- instead.
-}
-concurrentMessage :: Bool -> String -> Annex () -> Annex ()
+concurrentMessage :: OutputType -> Bool -> String -> Annex () -> Annex ()
+#ifdef WITH_CONCURRENTOUTPUT
+concurrentMessage o iserror msg fallback
+ | concurrentOutputEnabled o =
+ go =<< consoleRegion <$> Annex.getState Annex.output
+#endif
+ | otherwise = fallback
#ifdef WITH_CONCURRENTOUTPUT
-concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.output
where
go Nothing
| iserror = liftIO $ Console.errorConcurrent msg
@@ -48,9 +53,6 @@ concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.
rl <- takeTMVar Regions.regionList
putTMVar Regions.regionList
(if r `elem` rl then rl else r:rl)
-
-#else
-concurrentMessage _ _ fallback = fallback
#endif
{- Runs an action in its own dedicated region of the console.
@@ -62,21 +64,25 @@ concurrentMessage _ _ fallback = fallback
- When not at a console, a region is not displayed until the action is
- complete.
-}
-inOwnConsoleRegion :: Annex a -> Annex a
+inOwnConsoleRegion :: OutputType -> Annex a -> Annex a
+inOwnConsoleRegion o a
+#ifdef WITH_CONCURRENTOUTPUT
+ | concurrentOutputEnabled o = do
+ r <- mkregion
+ setregion (Just r)
+ eret <- tryNonAsync a `onException` rmregion r
+ case eret of
+ Left e -> do
+ -- Add error message to region before it closes.
+ concurrentMessage o True (show e) noop
+ rmregion r
+ throwM e
+ Right ret -> do
+ rmregion r
+ return ret
+#endif
+ | otherwise = a
#ifdef WITH_CONCURRENTOUTPUT
-inOwnConsoleRegion a = do
- r <- mkregion
- setregion (Just r)
- eret <- tryNonAsync a `onException` rmregion r
- case eret of
- Left e -> do
- -- Add error message to region before it closes.
- concurrentMessage True (show e) noop
- rmregion r
- throwM e
- Right ret -> do
- rmregion r
- return ret
where
-- The region is allocated here, but not displayed until
-- a message is added to it. This avoids unnecessary screen
@@ -94,8 +100,6 @@ inOwnConsoleRegion a = do
unless (T.null t) $
Console.bufferOutputSTM h t
Regions.closeConsoleRegion r
-#else
-inOwnConsoleRegion = id
#endif
{- The progress region is displayed inline with the current console region. -}
@@ -108,3 +112,24 @@ withProgressRegion a = do
instance Regions.LiftRegion Annex where
liftRegion = liftIO . atomically
#endif
+
+{- The concurrent-output library uses Text, which bypasses the normal use
+ - of the fileSystemEncoding to roundtrip invalid characters, when in a
+ - non-unicode locale. Work around that problem by avoiding using
+ - concurrent output when not in a unicode locale. -}
+concurrentOutputSupported :: IO Bool
+#ifdef WITH_CONCURRENTOUTPUT
+#ifndef mingw32_HOST_OS
+concurrentOutputSupported = do
+ enc <- getLocaleEncoding
+ return ("UTF" `isInfixOf` textEncodingName enc)
+#else
+concurrentOutputSupported = return True -- Windows is always unicode
+#endif
+#else
+concurrentOutputSupported = return False
+#endif
+
+concurrentOutputEnabled :: OutputType -> Bool
+concurrentOutputEnabled (ConcurrentOutput _ b) = b
+concurrentOutputEnabled _ = False
diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index fcbbe10b4..9b9edccc5 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -21,13 +21,13 @@ outputMessage json s = withOutputType go
go NormalOutput = liftIO $
flushed $ putStr s
go QuietOutput = q
- go (ConcurrentOutput _) = concurrentMessage False s q
+ go o@(ConcurrentOutput {}) = concurrentMessage o False s q
go JSONOutput = liftIO $ flushed json
outputError :: String -> Annex ()
outputError s = withOutputType go
where
- go (ConcurrentOutput _) = concurrentMessage True s (go NormalOutput)
+ go o@(ConcurrentOutput {}) = concurrentMessage o True s (go NormalOutput)
go _ = liftIO $ do
hFlush stdout
hPutStr stderr s
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index 25d803b1b..6bbf43f4c 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -46,16 +46,16 @@ metered combinemeterupdate key a = case keySize key of
liftIO $ clearMeter stdout meter
return r
#if WITH_CONCURRENTOUTPUT
- go size (ConcurrentOutput _) = withProgressRegion $ \r -> do
- (progress, meter) <- mkmeter size
- a $ \n -> liftIO $ do
- setP progress $ fromBytesProcessed n
- s <- renderMeter meter
- Regions.setConsoleRegion r ("\n" ++ s)
- maybe noop (\m -> m n) combinemeterupdate
-#else
- go _ (ConcurrentOutput _) = nometer
+ go size o@(ConcurrentOutput {})
+ | concurrentOutputEnabled o = withProgressRegion $ \r -> do
+ (progress, meter) <- mkmeter size
+ a $ \n -> liftIO $ do
+ setP progress $ fromBytesProcessed n
+ s <- renderMeter meter
+ Regions.setConsoleRegion r ("\n" ++ s)
+ maybe noop (\m -> m n) combinemeterupdate
#endif
+ | otherwise = nometer
mkmeter size = do
progress <- liftIO $ newProgress "" size
@@ -69,14 +69,14 @@ metered combinemeterupdate key a = case keySize key of
concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
concurrentMetered combinemeterupdate key a = withOutputType go
where
- go (ConcurrentOutput _) = metered combinemeterupdate key a
+ go (ConcurrentOutput {}) = metered combinemeterupdate key a
go _ = a (fromMaybe nullMeterUpdate combinemeterupdate)
{- Poll file size to display meter, but only for concurrent output. -}
concurrentMeteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
concurrentMeteredFile file combinemeterupdate key a = withOutputType go
where
- go (ConcurrentOutput _) = metered combinemeterupdate key $ \p ->
+ go (ConcurrentOutput {}) = metered combinemeterupdate key $ \p ->
watchFileSize file p a
go _ = a
@@ -120,6 +120,6 @@ mkStderrEmitter :: Annex (String -> IO ())
mkStderrEmitter = withOutputType go
where
#ifdef WITH_CONCURRENTOUTPUT
- go (ConcurrentOutput _) = return Console.errorConcurrent
+ go o | concurrentOutputEnabled o = return Console.errorConcurrent
#endif
go _ = return (hPutStrLn stderr)
diff --git a/Types/Messages.hs b/Types/Messages.hs
index f9e09ecd7..20c8051a0 100644
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -15,7 +15,7 @@ import Data.Default
import System.Console.Regions (ConsoleRegion)
#endif
-data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int | JSONOutput
+data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int Bool | JSONOutput
deriving (Show)
data SideActionBlock = NoBlock | StartBlock | InBlock
diff --git a/debian/changelog b/debian/changelog
index 7c8910f82..49d98d6e1 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -3,6 +3,9 @@ git-annex (6.20160212) UNRELEASED; urgency=medium
* Support getting files from read-only repositories.
* checkpresentkey: Allow to be run without an explicit remote.
* checkpresentkey: Added --batch.
+ * Work around problem with concurrent-output when in a non-unicode locale
+ by avoiding use of it in such a locale. Instead -J will behave as if
+ it was built without concurrent-output support in this situation.
-- Joey Hess <id@joeyh.name> Fri, 12 Feb 2016 14:03:46 -0400
diff --git a/doc/bugs/Unable_to_parallel_fsck.mdwn b/doc/bugs/Unable_to_parallel_fsck.mdwn
index 2d419915d..487552f54 100644
--- a/doc/bugs/Unable_to_parallel_fsck.mdwn
+++ b/doc/bugs/Unable_to_parallel_fsck.mdwn
@@ -81,3 +81,8 @@ Plenty. In fact I've been using it for a long time - I just only recently tried
[[!meta title="-J can crash on displaying filenames not supported by current locale"]]
+
+> I've worked around this by detecting the non-unicode locale and avoiding
+> the fancy concurrent output which needs it. So -J will work, just not
+> with concurrent progress. I think this is the best that can be done
+> reasonably, so [[done]]. --[[Joey]]