-
Notifications
You must be signed in to change notification settings - Fork 0
/
afp-scanudc.hs
85 lines (78 loc) · 2.85 KB
/
afp-scanudc.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
module Main where
import OpenAFP
import System.Mem
import System.Directory
import Control.Concurrent
import qualified Control.Exception as E (try, catch, throwIO, Exception(..))
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
isUDC :: N1 -> Bool
isUDC hi = hi >= 0x92 && hi <= 0xFE
-- | The main program: Scan all files in the argument line
-- (by default, every file in the current directory if none is specified)
-- for UDC characters, then output those that has UDC characters set
-- so the calling program can make use of that list to call afp-udcfix
-- to correct those UDC characters. (N.B.: Maybe we should launch afp-udcfix
-- by ourselves here?)
main :: IO ()
main = do
args <- getArgs
files <- filterM doesFileExist =<< case args of
(_:_) -> return args
[] -> getDirectoryContents "."
seq (length files) . (`mapM_` sort files) $ \fn -> do
rv <- scanUDC fn
when rv (putStrLn fn)
-- doAllLists files
where
doAllLists [] = return ()
doAllLists xs = do
mvs <- doHyperLists these
rvs <- mapM takeMVar mvs
mapM_ putStrLn [ file | (True, file) <- rvs `zip` these ]
performGC
doAllLists rest
where
(these, rest) = splitAt 10 xs
doHyperLists [] = return []
doHyperLists (fn:fns) = do
mv <- newEmptyMVar
forkIO $ do
rv <- scanUDC fn
putMVar mv rv
mvs <- doHyperLists fns
return (mv:mvs)
scanUDC :: FilePath -> IO Bool
scanUDC file = do
rv <- E.try $ readAFP file :: IO (Either SomeException [AFP_])
case rv of
Right cs -> (`E.catch` hdl) $ do
let ptxs = length cs `seq` filter (~~ _PTX) cs
mapM_ (scanPTX . decodeChunk) ptxs
return False
_ -> return False -- skip non-afp files
where
tryOpen = openBinaryFile file ReadMode `E.catch` tryErr
tryErr e | Just ioe <- cast e, isFullError ioe = threadDelay 200 >> tryOpen
tryErr e = E.throwIO (e :: SomeException)
hdl :: SomeException -> IO Bool
hdl e | Just ioe <- cast e, isUserError ioe = return True
hdl _ = return False
scanPTX :: PTX -> IO ()
scanPTX ptx = mapM_ ptxGroupScan . splitRecords _PTX_SCFL $ readChunks ptx
ptxGroupScan :: [PTX_] -> IO ()
ptxGroupScan (!scfl:cs) = seq (length cs) $ do
scflId <- ptx_scfl `applyToChunk` scfl
case scflId of
1 -> return ()
_ -> do
let trns = filter (~~ _PTX_TRN) cs
(`mapM_` trns) $ \trn -> scanTRN (decodeChunk trn)
scanTRN :: PTX_TRN -> IO ()
scanTRN trn = B.unsafeUseAsCStringLen (packBuf $ ptx_trn trn) $ \(cstr, len) -> do
forM_ [0, 2..len-1] $ \off -> do
hi <- peekByteOff cstr off
when (isUDC hi) $ do
-- lo <- peekByteOff cstr (off+1)
-- print [hi, lo]
throwError (strMsg "Found UDC")