diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright 2004-2008 by Audrey Tang + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/OpenAFP-Utils.cabal b/OpenAFP-Utils.cabal new file mode 100644 --- /dev/null +++ b/OpenAFP-Utils.cabal @@ -0,0 +1,60 @@ +Name: OpenAFP-Utils +Version: 1.1 +License: BSD3 +License-file: LICENSE +Author: Audrey Tang +Maintainer: audreyt@audreyt.org +Synopsis: Assorted utilities to work with AFP data streams +Description: Assorted utilities to work with AFP data streams +Category: Data +Build-type: Simple + +Executable: afp-dump +Main-is: afp-dump.hs +Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml +Extensions: DeriveDataTypeable, PatternGuards + +Executable: afp-page +Main-is: afp-page.hs +Build-depends: OpenAFP, haskell98, base + +Executable: afp-replace +Main-is: afp-replace.hs +Build-depends: OpenAFP, haskell98, base +Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards + +Executable: afp-scanudc +Main-is: afp-scanudc.hs +Build-depends: OpenAFP, haskell98, base, directory +Extensions: BangPatterns + +Executable: afp-split +Main-is: afp-split.hs +Build-depends: OpenAFP, haskell98, base + +Executable: afp-split-scb +Main-is: afp-split-scb.hs +Build-depends: OpenAFP, haskell98, base + +Executable: afp-split-tcb +Main-is: afp-split-tcb.hs +Build-depends: OpenAFP, haskell98, base, filepath +Extensions: ImplicitParams + +Executable: afp-type +Main-is: afp-type.hs +Build-depends: OpenAFP, haskell98, base + +Executable: afp-udcfix +Main-is: afp-udcfix.hs +Build-depends: OpenAFP, haskell98, base, regex-base, regex-posix +Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts + +Executable: afp-validate +Main-is: afp-validate.hs +Build-depends: OpenAFP, haskell98, base + +Executable: afp2line +Main-is: afp2line.hs +Build-depends: OpenAFP, haskell98, base +Extensions: GeneralizedNewtypeDeriving diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,10 @@ +#!/usr/bin/env runghc +\begin{code} + +module Main where +import Distribution.Simple + +main :: IO () +main = defaultMain + +\end{code} diff --git a/afp-dump.hs b/afp-dump.hs new file mode 100644 --- /dev/null +++ b/afp-dump.hs @@ -0,0 +1,222 @@ +module Main where +import Text.XHtml +import Codec.Text.UConv +import OpenAFP hiding ((!)) +import qualified Data.Set as Set +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import qualified Data.HashTable as H + +-- The key here is inventing a ConcreteDataView for our data structure. +-- See OpenAFP.Types.View for details. + +type Encodings = [String] + +data Opts = Opts + { encodings :: Encodings + , inputFile :: String + , openOutputHandle :: IO Handle + , verbose :: Bool + , showHelp :: IO () + } deriving (Typeable) + +defaultOpts :: Opts +defaultOpts = Opts + { encodings = ["937", "500"] + , inputFile = requiredOpt usage "input" + , openOutputHandle = return stdout + , verbose = False + , showHelp = return () + } + +usage :: String -> IO a +usage = showUsage options showInfo + where + showInfo prg = + "Usage: " ++ prg ++ " [-e enc,enc...] input.afp > output.html\n" ++ + "( example: " ++ prg ++ " -e 437,947 big5.afp > output.html)" + +options :: [OptDescr (Opts -> Opts)] +options = + [ reqArg "e" ["encodings"] "ENC,ENC..." "Text encodings (default: 937,500)" + (\s o -> o { encodings = splitComma s }) + , reqArg "i" ["input"] "FILE" "Input AFP file" + (\s o -> o { inputFile = s }) + , reqArg "o" ["output"] "FILE" "Output HTML file" + (\s o -> o { openOutputHandle = openFile s WriteMode }) + , noArg "h" ["help"] "Show help" + (\o -> o { showHelp = usage "" }) + ] + +splitComma :: String -> [String] +splitComma "" = [] +splitComma s = l : case s' of + [] -> [] + (_:s'') -> splitComma s'' + where + (l, s') = break (== ',') s + + +getOpts :: IO Opts +getOpts = do + args <- getArgs + (optsIO, rest, errs) <- return . getOpt Permute options $ procArgs args + return $ foldl (flip ($)) defaultOpts optsIO + where + procArgs xs + | null xs = ["-h"] + | even $ length xs = xs + | otherwise = init xs ++ ["-i", last xs] + +run :: IO () +run = withArgs (words "-e 937,500 -i ln-1.afp -o x.html") main + +main :: IO () +main = do + opts <- getOpts + let input = inputFile opts + cs <- readAFP input + fh <- openOutputHandle opts + writeIORef encsRef $ encodings opts + let put = hPutStr fh + put "" + put "" + put "" + put $ htmlPage input + put "
    " + mapM_ (hPutStrLn fh . (`withChunk` (showHtmlFragment . recHtml . recView))) cs + put "
" + hClose fh + +{-# NOINLINE encs #-} +encs :: Encodings +encs = unsafePerformIO (readIORef encsRef) + +{-# NOINLINE encsRef #-} +encsRef :: IORef Encodings +encsRef = unsafePerformIO (newIORef (error "oops")) + +htmlPage :: String -> String +htmlPage title = showHtmlFragment + [ header << + [ meta ! + [ httpequiv "Content-Type" + , content "text/html; charset=UTF-8" + ] + , thetitle << ("AFP Dump - " ++ title) + , style ! + [thetype "text/css" + ] << styles + ] + , h1 << title + ] + +styles :: String +styles = unlines [ + "body { background: #e0e0e0; font-family: times new roman, times; margin-left: 20px }", + "h1 { font-family: times new roman, times }", + "span { font-family: andale mono, courier }", + "ol { border-left: 1px dotted black }", + "ol.top { border-left: none }", + "table { font-size: small; border: 0px; border-left: 1px dotted black; padding-left: 6pt; width: 100% }", + "td.label { background: #d0d0d0; font-family: arial unicode ms, helvetica }", + "td.item { background: white; width: 100%; font-family: arial unicode ms, helvetica }", + "div { text-decoration: underline; background: #e0e0ff; font-family: arial unicode ms, helvetica }" + ] + +recHtml :: ViewRecord -> Html +recHtml (ViewRecord t fs) + | t == typeOf _PTX_TRN + , (_ : ViewField _ (ViewNStr _ nstr) : []) <- fs + = li << (typeHtml t +++ ptxHtml (map N1 (S.unpack nstr))) + | otherwise + = li << (typeHtml t +++ fieldsHtml fs) + +{-# NOINLINE _TypeHtmlCache #-} +_TypeHtmlCache :: H.HashTable RecordType Html +_TypeHtmlCache = unsafePerformIO $ H.new (==) (hashInt . typeInt) + +{-# NOINLINE _FontToEncoding #-} +_FontToEncoding :: HashTable N1 Encoding +_FontToEncoding = unsafePerformIO $ hashNew (==) fromIntegral + +typeHtml :: RecordType -> Html +typeHtml t = unsafePerformIO $ do + rv <- H.lookup _TypeHtmlCache t + case rv of + Just html -> return html + _ -> do + let html = typeHtml' t + H.insert _TypeHtmlCache t html + return html + +typeHtml' :: RecordType -> Html +typeHtml' t = thediv << (typeStr +++ primHtml " — " +++ typeDesc) + where + typeStr = bold << reverse (takeWhile (/= '.') (reverse typeRepr)) + typeDesc = stringToHtml $ descLookup (MkChunkType $ typeInt t) + typeRepr = show t + +ptxHtml :: [N1] -> [Html] +ptxHtml nstr = [table << textHtml] + where + textHtml = textLine ++ [ nstrLine ] + textLine = [ fieldHtml (ViewField (C.pack $ "(" ++ n ++ ")") (ViewString (typeOf ()) (C.pack txt))) | (n, txt) <- texts nstr ] + nstrLine = tr << td ! [colspan 2] << thespan << nstrHtml nstr + +texts nstr = maybeToList $ msum [ maybe Nothing (Just . ((,) cp)) $ conv (codeName cp) | cp <- encs ] + where + conv c@"ibm-937" + | (even $ length nstr) = convert c "utf8" (packNStr $ toNStr (0x0E : nstr)) + | otherwise = Nothing + conv c = convert c "utf8" (packNStr $ toNStr nstr) + codeName c + | isJust $ find (not . isDigit) c = c + | otherwise = "ibm-" ++ c + +fieldsHtml :: [ViewField] -> [Html] +fieldsHtml fs = [table << fsHtml] ++ membersHtml + where + fsHtml = [ map fieldHtml fields ] + membersHtml = chunksHtml $ csHtml ++ dataHtml + csHtml = [ c | ViewField _ (ViewChunks t c) <- fs ] + dataHtml = [ c | ViewField _ (ViewData t c) <- fs ] + fields = sortBy fieldOrder [ v | v@(ViewField str _) <- fs, strOk str ] + fieldOrder (ViewField a _) (ViewField b _) + | S.null a = GT + | S.null b = LT + | otherwise = compare a b + strOk str + | S.null str = True + | '_' <- C.head str = False + | otherwise = Set.notMember str blobFields + + +blobFields :: Set.Set FieldLabel +blobFields = Set.fromList $ map C.pack + [ "Data", "EscapeSequence", "Chunks", "ControlCode", "CC", "FlagByte", "Type", "SubType" ] + +chunksHtml :: [[ViewRecord]] -> [Html] +chunksHtml [] = [] +chunksHtml (cs:_) = [olist << map recHtml cs] + +fieldHtml (ViewField str content) + | S.null str = case content of + ViewNStr _ nstr | S.null nstr -> noHtml + _ -> tr << td ! [colspan 2, theclass "item"] << contentHtml content + | otherwise = tr << [td ! [theclass "label"] << C.unpack str, td ! [theclass "item"] << contentHtml content ] + +contentHtml :: ViewContent -> Html +contentHtml x = case x of + ViewNumber _ n -> stringToHtml $ show n + ViewString _ s -> stringToHtml $ ['"'] ++ C.unpack s ++ ['"'] + ViewNStr _ cs -> thespan << nstrHtml (map N1 (S.unpack cs)) + _ -> error (show x) + +nstrHtml :: [N1] -> String +nstrHtml nstr + | length nstr >= 80 = nstrStr nstr ++ "..." + | otherwise = nstrStr nstr + where + nstrStr :: [N1] -> String + nstrStr = concatMap ((' ':) . show) diff --git a/afp-page.hs b/afp-page.hs new file mode 100644 --- /dev/null +++ b/afp-page.hs @@ -0,0 +1,48 @@ +module Main where +import OpenAFP +import System.Exit +import qualified Data.ByteString.Char8 as C + +main :: IO () +main = do + args <- getArgs + if null args then error "Usage: afp-page file.afp [output.afp]" else do + cs <- readAFP $ head args + let outputFile = case args of + (_:fn:_) -> fn + _ -> "output.afp" + cs' <- cs !==>! + [ _MCF === (`filterChunks` + [ _MCF_T === (`filterChunks` + [ _T_FQN === fqnHandler + , _T_RLI ... io . writeIORef cnt . fromEnum . t_rli + ]) + ]) + ] + writeAFP outputFile cs' + +{-# NOINLINE cnt #-} +cnt :: IORef Int +cnt = unsafePerformIO (newIORef 0) + +cs !==>! list = iter cs + where + iter [] = return [] + iter (c:cs) = do + this <- c `chunkMapFiltersM` list + rest <- unsafeInterleaveIO (iter cs) + return $ this ++ rest + +fqnHandler fqn = do + c <- io $ readIORef cnt + let fqn' = case c of + 0 -> fqnDBCS + 35 -> fqnDBCS + _ | isM__T -> fqnDBCS + _ -> fqn + push fqn' + where + a = packAStr (t_fqn fqn) + isM__T = (C.length a >= 6) && ((C.index a 2 == 'M') || (C.index a 5 == 'T')) + fqnDBCS = fqn{ t_fqn = toAStr "T0XXXX " } + diff --git a/afp-replace.hs b/afp-replace.hs new file mode 100644 --- /dev/null +++ b/afp-replace.hs @@ -0,0 +1,263 @@ +module Main where +import OpenAFP +import qualified Data.ByteString.Lazy as L + +type Map = [([N1], [N1])] +type Maps = IORef [Map] + +main :: IO () +main = do + opts <- getOpts + fms <- readMaps opts + cs <- readInputAFP opts + fh <- openOutputAFP opts + mapref <- newIORef [] + scflref <- newIORef [] + sidref <- newIORef 1 + runReaderT (stateMain fh cs) opts + { currentMap = mapref + , scflStack = scflref + , scflID = sidref } { maps = fms } + hClose fh + +stateMain :: (Binary c, MonadReader Opts m, MonadIO m, Chunk c) + => Handle -> [c] -> m () +stateMain fh chunks = forM_ (splitRecords _PGD chunks) $ \cs -> do + cs' <- pageHandler cs + io $ L.hPutStr fh (encodeList cs') + +pageHandler :: (Chunk t, MonadReader Opts m, MonadIO m) + => [t] -> m [t] +pageHandler page = do + ptxList <- sequence [ ptx_Chunks `applyToChunk` c | c <- page, c ~~ _PTX ] + trnList <- sequence [ ptx_trn `applyToChunk` c | c <- concat ptxList, c ~~ _PTX_TRN ] + let strList = map fromNStr trnList + -- check each strList against each map element + -- if one matches the length, return the munged page, and nix the map from mapList + fms <- readVar maps + case find (matchMap strList) fms of + Nothing -> return page + Just fm -> do + verbose $$ "Matched..." + currentMap $= mungeMap $ fm + maps $= delete fm $ fms + mungePage page + +mungeMap :: Map -> Map +mungeMap = concatMap mungePair + +mungePair :: ([N1], [N1]) -> Map +mungePair (key, val) = splitChunks key `zip` (val:repeat []) + +_pretty :: [[N1]] -> [String] +_pretty = map $ map (chr . fromEnum) + +matchMap :: [[N1]] -> Map -> Bool +matchMap strList fm + -- | trace (unlines $ _pretty matched) True + -- | trace (show (length matched, length keys)) True + = (length matched >= length keys) + where + matched = filter matchOne strList + keys = concatMap splitChunks keysList + keysList = map fst fm + matchOne str + | str `elem` keys + = True + | length str < 2 + = False + | last str == 0x40 + , last (init str) == 0xA1 + = matchOne (init (init str)) + | otherwise +-- , trace (map (chr . fromEnum) str) True + = False + +splitChunks :: [N1] -> [[N1]] +splitChunks = foldr joinChunks [] . strChunks + +joinChunks :: [N1] -> [[N1]] -> [[N1]] +joinChunks xs [] = [xs] +joinChunks [x] ((y:ys):rest) | y <= 0x80 = (x:y:ys):rest +joinChunks [x1,x2] ((y:ys):rest) | y >= 0x80 = (x1:x2:y:ys):rest +joinChunks xs rest = xs:rest + +strChunks :: [N1] -> [[N1]] +strChunks [] = [] +strChunks (hi:lo:xs) | hi >= 0x80 = ([hi, lo] : strChunks xs) +strChunks (x:xs) = [x] : strChunks xs + +mungePage :: (Chunk c, MonadReader Opts t, MonadIO t) + => [c] -> t [c] +mungePage page = do + page ==> + [ _MCF ... mcfHandler + , _PTX === (`filterChunks` + [ _PTX_TRN === trnHandler + , _PTX_SCFL === scflHandler + ]) + ] + +-- | Record font Id to Name mappings in MCF's RLI and FQN chunks. +mcfHandler :: (RecChunk r, MonadIO m, MonadReader Opts m) + => r -> m () +mcfHandler r = do + readChunks r ..> + [ _MCF_T ... \mcf -> do + fnt <- asks font + let cs = readChunks mcf + ids <- sequence [ t_rli `applyToChunk` c | c <- cs, c ~~ _T_RLI ] + fonts <- sequence [ t_fqn `applyToChunk` c | c <- cs, c ~~ _T_FQN ] + let alist = map fromAStr fonts `zip` ids + case lookup fnt alist of + Just sid -> do + verbose $$ ("Found font ID for " ++ fnt ++ ": " ++ (show sid)) + scflID $= id $ sid + return () + Nothing -> return () + ] + +scflHandler :: (MonadReader Opts m, MonadIO m) + => PTX_SCFL -> m () +scflHandler r = do + scfls <- readVar scflStack + scflStack $= id $ (r:scfls) + +trnHandler :: (Chunk c, MonadIO m, MonadReader Opts m) + => PTX_TRN -> WriterT (ChunkQueue c) m () +trnHandler r = do + let trnOld = fromNStr $ ptx_trn r + fm <- readVar currentMap + scfls <- readVar scflStack + sid <- readVar scflID + case fm of + ((trn, rv):rest) | trn == trnOld -> do + -- verbose $$ map (chr . fromEnum) trn + currentMap $= id $ rest + case scfls of + [] -> do + let rst = (ptx_trn_Type r `mod` 2) + typ = (ptx_scfl_Type _PTX_SCFL) + push _PTX_SCFL{ ptx_scfl = sid, ptx_scfl_Type = typ + rst } + push _PTX_SCFL{ ptx_scfl = sid, ptx_scfl_Type = typ + (1-rst) } + (s:ss) -> mapM_ push $ reverse (s{ ptx_scfl = 1 }:ss) + unless (null rv) $ do + let trn' = toNStr rv + verbose $$ ("From:[" ++ map (chr . fromEnum) trnOld ++ "]") + verbose $$ ("To: [" ++ map (chr . fromEnum) rv ++ "]") + push r { ptx_trn = trn' } + return () + _ -> do + mapM_ push $ reverse scfls + push r + scflStack $= id $ [] + +usage :: String -> IO a +usage = showUsage options showInfo + where + showInfo prg = + "Usage: " ++ prg ++ " -m map.txt -i input.afp -o output.afp\n" + +data Opts = Opts + { readMaps :: IO Maps + , maps :: Maps + , currentMap :: IORef Map + , readInputAFP :: IO [AFP_] + , openOutputAFP :: IO Handle + , font :: String + , verbose :: Bool + , showHelp :: IO () + , scflStack :: IORef [PTX_SCFL] + , scflID :: IORef N1 + } deriving (Typeable) + +defaultOpts :: Opts +defaultOpts = Opts + { readMaps = requiredOpt usage "map" + , currentMap = undefined + , maps = requiredOpt usage "map" + , readInputAFP = requiredOpt usage "input" + , openOutputAFP = requiredOpt usage "output" + , font = requiredOpt usage "font" + , verbose = True + , showHelp = return () + , scflStack = undefined + , scflID = undefined + } + +options :: [OptDescr (Opts -> Opts)] +options = + [ reqArg "m" ["map"] "FILE" "Replacement map" + (\s o -> o { readMaps = newIORef . makeMaps =<< readFile s }) + , reqArg "i" ["input"] "FILE" "Input AFP file" + (\s o -> o { readInputAFP = readAFP s }) + , reqArg "o" ["output"] "FILE" "Output AFP file" + (\s o -> o { openOutputAFP = openBinaryFile s WriteMode }) + , reqArg "f" ["font"] "NAME" "Font name" + (\s o -> o { font = s }) + , noArg "v" ["verbose"] "Print progress information" + (\o -> o { verbose = True }) + , noArg "h" ["help"] "Show help" + (\o -> o { showHelp = usage "" }) + ] + +run :: IO () +-- run = withArgs (split " " "-v -m SC27.add -i SC27.AFP -o output.afp") main +run = runWith "-v -m 1-map.txt -i 1-in.afp -o 1-out.afp -f X0FDB000" + +runWith :: String -> IO () +runWith str = withArgs (words str) main + +makeMaps :: String -> [Map] +makeMaps str = entries + where + entries :: [Map] + entries = map (pair . lines) groups + pair [] = [] + pair (a:b:[]) = [(ordList a, checkDBCS $ ordList b)] + pair (a:b:[]:rest) = (ordList a, checkDBCS $ ordList b) : pair rest + pair x = error $ "Bad pair: " ++ (show x) + groups = split "\n\n--\n--\n\n" str + ordList :: (Enum a, Enum b) => [a] -> [b] + ordList = map (toEnum . fromEnum) + checkDBCS [] = [] + checkDBCS (x:y:xs) | x > 0x7F = (x:y:checkDBCS xs) + checkDBCS x = error $ "Not DBCS: " ++ ordList x + +getOpts :: IO Opts +getOpts = do + args <- getArgs + (optsIO, _rest, _errs) <- return . getOpt Permute options $ procArgs args + return $ foldl (flip ($)) defaultOpts optsIO + where + procArgs [] = ["-h"] + procArgs xs = xs + +-- | Split a list into pieces that were held together by glue. Example: +-- +-- > split ", " "one, two, three" ===> ["one","two","three"] + +split :: Eq a => [a] -- ^ Glue that holds pieces together + -> [a] -- ^ List to break into pieces + -> [[a]] -- ^ Result: list of pieces + +split glue xs = split' xs + where + split' [] = [] + split' xs' = piece : split' (dropGlue rest) + where (piece, rest) = breakOnGlue glue xs' + dropGlue = drop (length glue) + +-- | Break off the first piece of a list held together by glue, +-- leaving the glue attached to the remainder of the list. Example: +-- +-- > breakOnGlue ", " "one, two, three" ===> ("one", ", two, three") + +breakOnGlue :: (Eq a) => [a] -- ^ Glue that holds pieces together + -> [a] -- ^ List from which to break off a piece + -> ([a],[a]) -- ^ Result: (first piece, glue ++ rest of list) + +breakOnGlue _ [] = ([],[]) +breakOnGlue glue rest@(x:xs) + | glue `isPrefixOf` rest = ([], rest) + | otherwise = (x:piece, rest') where (piece, rest') = breakOnGlue glue xs diff --git a/afp-scanudc.hs b/afp-scanudc.hs new file mode 100644 --- /dev/null +++ b/afp-scanudc.hs @@ -0,0 +1,84 @@ +module Main where +import OpenAFP +import System.Mem +import System.Directory +import Control.Concurrent +import qualified Control.Exception as E (try, catch, throwIO) +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 + 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 (IOException ioe) | isFullError ioe = threadDelay 200 >> tryOpen + tryErr e = E.throwIO e + hdl (IOException ioe) | Just e <- cast ioe, isUserError e = 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") diff --git a/afp-split-scb.hs b/afp-split-scb.hs new file mode 100644 --- /dev/null +++ b/afp-split-scb.hs @@ -0,0 +1,55 @@ +module Main where +import OpenAFP +import System.Exit +import Data.Char (isDigit, isAlphaNum) +import Data.List (find) +import qualified Data.ByteString.Char8 as C + +-- Algorithm: +-- Gather everything up to first BPG +-- write out each BPG/EPG chunks +-- append ENG+EDT + +main :: IO () +main = do + args <- getArgs + if null args then error "Usage: afp-split-scb file.afp [pages]" else do + let (inFile:outPages) = args + cs <- readAFP inFile + let (preamble:rest) = splitPages cs + _eng = encodeChunk $ Record _ENG + _edt = encodeChunk $ Record _EDT + pagePairs = map show [1..] `zip` rest + if null outPages + then forM_ pagePairs $ \(i, page) -> do + let Just tle = find (~~ _TLE) page + Just (_:av:_) = tle_Chunks `applyToChunk` tle + Just str = t_av `applyToChunk` av + pgs = filter (~~ _BPG) page + -- + Just seg = find (~~ _IPS) page + Just name = ips `applyToChunk` seg + -- + outFile = inFile + ++ ('.':filter isDigit (fromAStr str)) + ++ ('.':takeWhile isAlphaNum (fromAStr name)) + ++ ('.':i) + ++ ('.':show (length pgs)) + + putStrLn outFile + writeAFP outFile $ preamble ++ page ++ [_eng, _edt] + else do + let outFile = inFile ++ ".part" + writeAFP outFile $ preamble ++ concat [ page | (i, page) <- pagePairs, i `elem` outPages ] ++ [_eng, _edt] + putStrLn outFile + +splitPages :: [AFP_] -> [[AFP_]] +splitPages cs = if null rest then [this] else case splitPages rest' of + [] -> [this, rest] + (y:ys) -> (this:(begins ++ y):ys) + where + (this, rest) = break isBeginPage cs + (begins, rest') = span isBeginPage rest + +isBeginPage :: AFP_ -> Bool +isBeginPage t = (t ~~ _BNG) diff --git a/afp-split-tcb.hs b/afp-split-tcb.hs new file mode 100644 --- /dev/null +++ b/afp-split-tcb.hs @@ -0,0 +1,124 @@ +module Main where +import OpenAFP +import System.Exit +import System.FilePath +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L + +-- Algorithm: +-- Gather everything up to first BPG +-- write out each BPG/EPG chunks +-- append ENG+EDT + +data PageSize = PSmall | PLarge deriving (Show) + +type MaybeHandleRef = IORef (Maybe Handle) + +initFh :: [AFP_] -> (MaybeHandleRef, FilePath) -> IO Handle +initFh chunks (ref, fn) = do + rv <- readIORef ref + case rv of + Just fh -> return fh + _ -> do + fh <- openBinaryFile fn WriteMode + L.hPut fh $ encodeList chunks + writeIORef ref (Just fh) + return fh + +finalizeFh :: [AFP_] -> MaybeHandleRef -> IO () +finalizeFh chunks ref = do + rv <- readIORef ref + case rv of + Just fh -> do + L.hPut fh $ encodeList chunks + hClose fh + _ -> return () + +main :: IO () +main = do + args <- getArgs + + let (inFile, maxSmallPages) = case args of + [] -> error "Usage: afp-split-tcb file.afp [max-small-pages (defaults to 3)]" + [x] -> (x, 3) + (x:y:_) -> (x, read y) + (dir, fn) = splitFileName inFile + + let ?maxSmallPages = maxSmallPages + + cs <- readAFP inFile + + let (preamble:rest) = splitPages cs + _edt = encodeChunk $ Record _EDT + + smallOpened <- newIORef Nothing + largeOpened <- newIORef Nothing + + forM_ rest $ \page -> do + fh <- initFh preamble $ case pageSizeOf page of + PSmall -> (smallOpened, dir `combine` "small_" ++ fn) + _ -> (largeOpened, dir `combine` "large_" ++ fn) + L.hPut fh $ encodeList page + + finalizeFh [_edt] smallOpened + finalizeFh [_edt] largeOpened + +isBeginPage :: AFP_ -> Bool +isBeginPage t = (t ~~ _BPG) || (t ~~ _BNG) + +-- Find the non-zero AMB with lowest number +pageSizeOf :: (?maxSmallPages :: Int) => [AFP_] -> PageSize +pageSizeOf [] = PSmall +pageSizeOf cs = case sortBy compareAMB rows of + [] -> PSmall -- A page with no text? + (row:_) -> case sortBy compareTRN [packNStr $ ptx_trn (decodeChunk c) | c <- row, c ~~ _PTX_TRN] of + [] -> PSmall -- A column with no TRN? + (col:_) -> case [ S.map fromDigitLike x | x <- S.splitWith (not . isDigitLike) col, not (S.null x) ] of + [] -> PSmall -- No digits :-/ + xs -> case C.readInt (last xs) of + Nothing -> trace (shows xs ": Non-parsable") PSmall -- A non-numeric token? + Just (i, _) | i <= ?maxSmallPages -> trace (shows xs ": Small") PSmall + | otherwise -> trace (shows xs ": Large") PLarge + where + rows = case splitRecords _PTX_AMB $ concat [ptx_Chunks $ decodeChunk c | c <- cs, c ~~ _PTX ] of + [] -> [] + (_:xs) -> xs + compareTRN x y = compare (C.length y) (C.length x) + compareAMB (x:_) (y:_) = compare (ambOf x) (ambOf y) + compareAMB _ _ = EQ + ambOf c = case ptx_amb $ decodeChunk c of + 0 -> maxBound -- We don't really care about rows with AMB 0. + x -> x + +fromDigitLike :: Word8 -> Word8 +fromDigitLike n + | n >= 0xF0 = n - 0xC0 + | otherwise = n + +isDigitLike :: Word8 -> Bool +isDigitLike n = (n >= 0x30 && n <= 0x39) || (n >= 0xF0 && n <= 0xF9) + +-- | Selects words corresponding to white-space characters in the Latin-1 range +-- ordered by frequency. +isSpaceWord8' :: Word8 -> Bool +isSpaceWord8' w = + w == 0x20 || + w == 0x00 || -- This Case Is Specific To Us + w == 0x0A || -- LF, \n + w == 0x09 || -- HT, \t + w == 0x0C || -- FF, \f + w == 0x0D || -- CR, \r + w == 0x0B || -- VT, \v + w == 0xA0 -- spotted by QC.. +{-# INLINE isSpaceWord8' #-} + + +splitPages :: [AFP_] -> [[AFP_]] +splitPages cs = if null rest then [this] else case splitPages rest' of + [] -> [this, rest] + (y:ys) -> (this:(begins ++ y):ys) + where + (this, rest) = break isBeginPage cs + (begins, rest') = span isBeginPage rest + diff --git a/afp-split.hs b/afp-split.hs new file mode 100644 --- /dev/null +++ b/afp-split.hs @@ -0,0 +1,40 @@ +module Main where +import OpenAFP +import System.Exit +import qualified Data.ByteString.Char8 as C + +-- Algorithm: +-- Gather everything up to first BPG +-- write out each BPG/EPG chunks +-- append ENG+EDT + +main :: IO () +main = do + args <- getArgs + if null args then error "Usage: afp-split file.afp [pages]" else do + let (inFile:outPages) = args + cs <- readAFP inFile + let (preamble:rest) = splitPages cs + _eng = encodeChunk $ Record _ENG + _edt = encodeChunk $ Record _EDT + pagePairs = map show [1..] `zip` rest + if null outPages + then forM_ pagePairs $ \(i, page) -> do + let outFile = inFile ++ ('.':i) + putStrLn outFile + writeAFP outFile $ preamble ++ page ++ [_eng, _edt] + else do + let outFile = inFile ++ ".part" + writeAFP outFile $ preamble ++ concat [ page | (i, page) <- pagePairs, i `elem` outPages ] ++ [_eng, _edt] + putStrLn outFile + +splitPages :: [AFP_] -> [[AFP_]] +splitPages cs = if null rest then [this] else case splitPages rest' of + [] -> [this, rest] + (y:ys) -> (this:(begins ++ y):ys) + where + (this, rest) = break isBeginPage cs + (begins, rest') = span isBeginPage rest + +isBeginPage :: AFP_ -> Bool +isBeginPage t = (t ~~ _BPG) diff --git a/afp-type.hs b/afp-type.hs new file mode 100644 --- /dev/null +++ b/afp-type.hs @@ -0,0 +1,13 @@ +module Main where +import OpenAFP + +main :: IO () +main = do + args <- getArgs + if null args then error "Usage: afp-type file.afp" else do + cs <- readAFP $ head args + case find (~~ _ER) cs of + Nothing -> return () + Just c -> do + resName <- er `applyToChunk` c + putStrLn $ fromAStr resName diff --git a/afp-udcfix.hs b/afp-udcfix.hs new file mode 100644 --- /dev/null +++ b/afp-udcfix.hs @@ -0,0 +1,583 @@ +module Main where +import OpenAFP +import qualified Data.Map as Map +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Data.Int +import Text.Regex.Posix +import Text.Regex.Base.RegexLike + +-- | Flags. +type VarsIO a = StateIO Vars a + +-- | Global configuration parameters. +dbcsSpace, dbcsFirst :: NChar +dbcsSpace = (0x40, 0x40) +dbcsFirst = (0x4C, 0x41) + +isUDC :: N1 -> Bool +isUDC hi = hi >= 0x92 && hi <= 0xFE + +{-# NOINLINE _Vars #-} +_Vars :: IORef Vars +_Vars = unsafePerformIO $ newIORef undefined + +-- | The main program: initialize global variables, split the input +-- AFP file into "pages", then dispatch each page to pageHandler. +main :: IO () +main = do + writeIORef _Vars =<< initVars + stateMain + +instance MonadReader Vars IO where + ask = readIORef _Vars + local = undefined + +stateMain = do + chunks <- liftOpt readInputAFP + fh <- liftOpt openOutputAFP + forM_ (splitRecords _PGD chunks) $ \cs -> do + cs' <- pageHandler cs + io $ L.hPutStr fh (encodeList cs') + io $ hClose fh + +-- | Check a page's PTX records for UDC characters. If none is seen, +-- simply output the page; otherwise pass the page to udcPageHandler +-- and output the result. +pageHandler page = (`catchError` hdl) $ do + page ..> + [ _MCF ... mcfHandler + , _MCF1 ... mcf1Handler + , _PTX ... ptxCheckUDC + ] + return page + where + hdl err | Just e <- cast err, isUserError e = udcPageHandler page + | otherwise = throwError err + +-- | Record font Id to Name mappings in MCF's RLI and FQN chunks. +mcfHandler r = do + readChunks r ..> + [ _MCF_T ... \mcf -> do + let cs = readChunks mcf + ids <- sequence [ t_rli `applyToChunk` c | c <- cs, c ~~ _T_RLI ] + fonts <- sequence [ t_fqn `applyToChunk` c | c <- cs, c ~~ _T_FQN ] + _IdToFont %%= (ids `zip` map packAStr fonts) + ] + +-- | Record font Id to Name mappings in MCF1's Data chunks. +mcf1Handler r = do + _IdToFont %%= + [ (mcf1_CodedFontLocalId mcf1, packA8 $ mcf1_CodedFontName mcf1) + | Record mcf1 <- readData r + ] + +-- | Split PTX into "groups", each one begins with a SCFL chunk. +ptxCheckUDC r = length groups `seq` forM_ groups ptxGroupCheckUDC + where + groups = splitRecords _PTX_SCFL chunks + chunks = filter want (readChunks r) + want c = (c ~~ _PTX_SCFL) || (c ~~ _PTX_TRN) + +-- | Check a PTX to see if the leading SCFL indicates a DBCS font; +-- if yes, pass remaining TRN chunks to trnCheckUDC. +ptxGroupCheckUDC [] = return () +ptxGroupCheckUDC (scfl:trnList) = seq (length trnList) $ do + font <- readArray _IdToFont =<< ptx_scfl `applyToChunk` scfl + isDBCS <- fontIsDBCS &: font + when (isDBCS) . io $ do + forM_ (map (ptx_trn `applyToChunk`) trnList) + (>>= trnCheckUDC) + +-- | Look inside TRN buffers for UDC characters. If we find one, +-- raise an IO exception so the page handler can switch to UDC mode. +trnCheckUDC :: NStr -> IO () +trnCheckUDC nstr = S.unsafeUseAsCStringLen (packBuf nstr) $ \(cstr, len) -> do + forM_ [0, 2..len-1] $ \off -> do + hi <- peekByteOff cstr off + when (isUDC hi) $ do + throwError (strMsg "Found UDC") + +-- | The main handler for pages with UDC characters. +udcPageHandler page = do + (_X $= id) 0 + (_Y $= id) 0 + (_UDC $= id) [] + page ==> + [ _PGD ... _XPageSize $= pgd_XPageSize + , _MCF ... mcfHandler + , _MCF1 ... mcf1Handler + , _PTX === \ptx -> do + filterChunks ptx + [ _PTX_AMI ... _X $= ptx_ami + , _PTX_AMB ... _Y $= ptx_amb + , _PTX_RMI ... _X += ptx_rmi + , _PTX_RMB ... _Y += ptx_rmb + , _PTX_SCFL ... _FontId $= ptx_scfl + , _PTX_SBI ... _BaselineIncr $= ptx_sbi + , _PTX_SIM ... _InlineMargin $= ptx_sim + , _PTX_STO ... \sto -> do + _XOrientation $= ptx_sto_Orientation $ sto + _YOrientation $= ptx_sto_WrapDirection $ sto + , _PTX_BLN ... \_ -> do + x' <- readVar _InlineMargin + y' <- readVar _BaselineIncr + (_X $= id) x' + (_Y += id) y' + , _PTX_TRN === trnHandler + ] + , _EMO === endPageHandler + , _EPG === endPageHandler + ] + +trnHandler r = do + font <- currentFont + let trn = packNStr $ ptx_trn r + isDBCS <- fontIsDBCS &: font + case isDBCS of + True -> do + -- If font is double byte, transform the TRN with dbcsHandler. + db <- dbcsHandler font trn -- XXX + push r{ ptx_trn = mkBuf db } + False -> do + -- If font is single byte, simply add each byte's increments. + -- without parsing UDC. + let f tot ch = do + inc <- incrementOf font (0x00, if ch == 0x00 then 0x40 else N1 ch) + return (tot + inc) + inc <- foldM f 0 (S.unpack trn) + (_X += id) inc + push r + +dbcsHandler :: FontField -> ByteString -> VarsIO ByteString +dbcsHandler font bs = liftM (S.pack . map fromN1) (dbcsHandler' font (map N1 (S.unpack bs))) + +dbcsHandler' :: FontField -> [N1] -> VarsIO [N1] +dbcsHandler' _ [] = return [] +dbcsHandler' _ [x] = do + warn $ "invalid DBCS sequence: " ++ show x + return [] +dbcsHandler' font (hi:lo:xs) = do + (incChar, (hi', lo')) <- dbcsCharHandler font (hi, lo) + incr <- incrementOf font incChar + (_X += id) incr + rest <- dbcsHandler' font xs + return (hi':lo':rest) + +dbcsCharHandler font char@(hi, _) + | isUDC hi = do + x <- readVar _X + y <- readVar _Y + _UDC @= CharUDC + { udcX = x + , udcY = y + , udcChar = char + , udcFont = font + } + return (char, dbcsSpace) + | otherwise = return (dbcsFirst, char) + -- isNotDBCS hi = return (char, char) + +endPageHandler r = do + udcList <- readVar _UDC + unless (null udcList) $ do + xp <- readVar _XPageSize + xo <- readVar _XOrientation + yo <- readVar _YOrientation + forM_ (reverse udcList) $ \udc -> do + infoMaybe <- getFontInfo (udcFont udc) (udcChar udc) + case infoMaybe of + Just info | S.length (fromBuf0 $ fontBitmap info) > 0 -> do + push _BII + push _IOC + { ioc_XMap = 0x03E8 + , ioc_XOrientation = xo + , ioc_YMap = 0x03E8 + , ioc_YOrientation = yo + } + udcCharHandler xp yo udc info + push _EII + _ -> return () + push r + +udcCharHandler xp yo char info = do + base <- adjustY &: fontBaseOffset info + let (x, y) = orientate x' y' + x' = udcX char + (fromIntegral $ fontASpace info) + y' = udcY char - (fromIntegral $ base) + push _IID + { iid_Color = 0x0008 + , iid_ConstantData1 = 0x000009600960000000000000 + , iid_ConstantData2 = 0x000000002D00 + , iid_XUnits = fontResolution info + , iid_YUnits = fontResolution info + } + push _ICP + { icp_XCellOffset = x + , icp_XCellSize = fontWidth info + , icp_XFillSize = fontWidth info + , icp_YCellOffset = y + , icp_YCellSize = fontHeight info + , icp_YFillSize = fontHeight info + } + push _IRD { + ird_ImageData = fontBitmap info + } + where + orientate x y + | (yo == 0x5a00) = (xp - y, x) + | otherwise = (x, y) + +currentFont = readArray _IdToFont =<< readVar _FontId + +incrementOf x y = do + cachedLibReader _IncrCache fillInc 0 x y + where + fillInc font char@(hi, _) f redo = do + rv <- readIncrements font hi + if rv then liftM (maybe 0 id) redo else do + udcRef <- asks _UDC + io $ do + -- Remove this from the list of UDCs to gen image for + putStrLn $ "Skipping unknown UDC: " ++ show char ++ ", font: " ++ show (ck_font f) + modifyIORef udcRef (filter ((/= char) . udcChar)) + return 0 + +getFontInfo x y = do + cachedLibReader _InfoCache fillInfo (Just _FontInfo) x y + where + fillInfo font char key _ = do + infoMaybe <- readFontInfo font char + case infoMaybe of + Just info -> do + _InfoCache %= (key, infoMaybe) + _IncrCache %= (key, fontIncrement info) + return infoMaybe + _ -> return Nothing + +cachedLibReader :: (MonadIO m, MonadReader Vars m, MonadPlus m, MonadError e m, Show e, Typeable e) => + (Vars -> HashTable CacheKey a) + -> (ByteString -> NChar -> CacheKey -> m (Maybe a) -> m a) + -> a -> FontField -> NChar -> m a +cachedLibReader cache filler fallback font char = do + vars <- ask + let val = io $ hashLookup (cache vars) key + fillCache = filler font char key val + val >>= maybe (fillCache `catchError` hdl) return + where + key = cacheKey font char + hdl err | Just e <- cast err, isUserError e = {-# SCC "hdl" #-} do + let keySeen = cacheKey font (0x00, 0x00) + seen <- cache %? keySeen + when (isNothing seen) $ do + warn $ "font library does not exist: " ++ C.unpack font + cache %= (key, fallback) + cache %= (keySeen, fallback) + -- sequence_ [ cache %= (cacheKey font (fst char, lo), fallback) | <- [0x00 .. 0xFF] ] + return fallback + | otherwise = throwError err + +readIncrements font hi = do + cfi <- (_CFI <~~) =<< readFontlibAFP &<< font + case hi `matchRecordMaybe` cfi_Section $ cfi of + Nothing -> return False + Just cfi' -> do + fni <- _FNI `readLibRecord` cfi_FontCharacterSetName $ cfi' + cpi <- _CPI `readLibRecord` cfi_CodePageName $ cfi' + let gcgToIncr = Map.fromList . map (pair . fromRecord) $ readData fni + pair r = (fni_GCGID r, fni_CharacterIncrement r) + incr = maybe 0 id . (`Map.lookup` gcgToIncr) . cpi_GCGID + sequence_ [ _IncrCache %= (key r, incr r) | Record r <- readData cpi ] + return True + where + key r = cacheKey font (hi, cpi_CodePoint r) + +readFontInfo font char@(hi, _) = do + cfi <- (_CFI <~~) =<< readFontlibAFP &<< font + case (hi `matchRecordMaybe` cfi_Section) cfi of + Nothing -> return Nothing + Just cfi' -> liftM Just (cfiHandler char cfi') + +cfiHandler char@(_, lo) cfi = do + cpi_ <- _CPI `readLibRecord` cfi_CodePageName $ cfi + case lo `matchRecordMaybe` cpi_CodePoint $ cpi_ of + Nothing -> return _FontInfo + Just c -> run lo (cpi_GCGID c) cfi + where + run 0x40 0 x = return _FontInfo + run _ 0 x = cfiHandler (0x00, 0x40) x + run _ gcg x = do + io $ putStrLn ("Replacing UDC: " ++ show char) + fcsHandler gcg x + +fcsHandler gcg cfi = do + fcs <- readFontlibAFP &<< (fromFontField $ cfi_FontCharacterSetName cfi) + fni_ <- _FNI <~~ fcs + fnm_ <- _FNM <~~ fcs + fnc <- _FNC <~~ fcs + let fni = gcg `matchRecord` fni_GCGID $ fni_ + fnm = fromRecord $ readData fnm_ `genericIndex` fni_FNMCount fni + (w, h) = (1 + fnm_Width fnm, 1 + fnm_Height fnm) + bytes = ((w + 7) `div` 8) * h + fngs <- sequence [ fng `applyToChunk` n | n <- fcs, n ~~ _FNG ] + let bitmap = subBufs fngs (fnm_Offset fnm) bytes + + vars <- ask + when (verbose (_Opts vars)) $ do + let nstr = fromNStr bitmap + showBitmap nstr (bytes `div` h) + + return FontInfo + { fontIncrement = fni_CharacterIncrement fni + , fontAscend = fni_AscendHeight fni + , fontDescend = fni_DescendDepth fni + , fontASpace = fni_ASpace fni + , fontBSpace = fni_BSpace fni + , fontCSpace = fni_CSpace fni + , fontBaseOffset = fni_BaseOffset fni + , fontBitmap = bitmap + , fontWidth = w + , fontHeight = h + , fontResolution = fnc_UnitXValue fnc + } + +readLibRecord t f r = t `seq` f `seq` r `seq` ((t <~~) =<< readFontlibAFP &<< (fromFontField $ f r)) + +-- | Data structures. +data CharUDC = CharUDC + { udcX :: !N2 + , udcY :: !N2 + , udcChar :: !NChar + , udcFont :: !FontField + } deriving (Show) + +data FontInfo = FontInfo + { fontIncrement :: !N2 + , fontAscend :: !I2 + , fontDescend :: !I2 + , fontASpace :: !I2 + , fontBSpace :: !N2 + , fontCSpace :: !I2 + , fontBaseOffset :: !I2 + , fontBitmap :: !NStr + , fontWidth :: !N2 + , fontHeight :: !N2 + , fontResolution :: !N2 + } deriving (Show) + +_FontInfo = FontInfo 0 0 0 0 0 0 0 _NStr 0 0 0 + +-- | Simple test case. +run :: IO () +run = withArgs (words "-a -d NS.. -i tmp -o x -f /StreamEDP/fontlib") main + +data Vars = Vars + { _XPageSize :: !(IORef N2) + , _X :: !(IORef N2) + , _Y :: !(IORef N2) + , _XOrientation :: !(IORef N2) + , _YOrientation :: !(IORef N2) + , _InlineMargin :: !(IORef N2) + , _BaselineIncr :: !(IORef N2) + , _FontId :: !(IORef N1) + , _UDC :: !(IORef [CharUDC]) + , _IdToFont :: !(IOArray N1 FontField) + , _InfoCache :: !(HashTable CacheKey (Maybe FontInfo)) + , _IncrCache :: !(HashTable CacheKey N2) + , _Opts :: !Opts + } + +type Config = Int + +data CacheKey = MkCacheKey + { ck_hash :: !Int32 + , ck_font :: !ByteString + } + deriving Eq + +cacheKey :: ByteString -> NChar -> CacheKey +cacheKey font (hi, lo) = MkCacheKey + (hashString (chr (fromEnum hi) : chr (fromEnum lo) : C.unpack font)) + font + +initVars :: IO Vars +initVars = do + xp <- newIORef 0 + x <- newIORef 0 + y <- newIORef 0 + xo <- newIORef 0 + yo <- newIORef 0 + im <- newIORef 0 + bi <- newIORef 0 + fid <- newIORef 0 + udc <- newIORef [] + idf <- newIOArray (0x00, 0xFF) C.empty + ifc <- hashNew (==) ck_hash + inc <- hashNew (==) ck_hash + opt <- getOpts + return $ Vars xp x y xo yo im bi fid udc idf ifc inc opt + +getOpts = do + args <- getArgs + (optsIO, rest, errs) <- return . getOpt Permute options + $ if (null args) then ["-h"] else args + let opts = foldl (flip ($)) defaultOpts optsIO + suffix = fontlibSuffix opts + showHelp opts + unless (null rest) $ do + warn $ "unrecognized arguments: `" ++ concat (intersperse " " rest) ++ "'\n" + paths <- filterM checkPath $ fontlibPaths opts + when (null paths) $ do + die $ "cannot find a valid font library path" + fontIsDBCS opts `seq` forM_ errs warn + return opts{ readFontlibAFP = reader paths (fontlibSuffix opts) } + where + checkPath path = do + exists <- doesDirectoryExist (C.unpack path) + unless (exists) $ do + warn $ "directory does not exist: `" ++ C.unpack path ++ "'" + return exists + reader paths suffix name = do + -- Here we memoize by name. + let key = C.concat (suffix:name:paths) + rv <- hashLookup _ReaderCache key + case rv of + Just chunks -> return chunks + _ -> do + (afp:_) <- filterM doesFileExist + [ C.unpack f ++ "/" ++ fileName ++ C.unpack suffix | f <- paths ] + chunks <- readAFP afp + hashInsert _ReaderCache key (seq (length chunks) chunks) + return chunks + where + fileName = case C.unpack name of + ('X':_:xs) -> trim ('X':'0':xs) + xs -> trim xs + +{-# NOINLINE _ReaderCache #-} +_ReaderCache :: HashTable ByteString [AFP_] +_ReaderCache = unsafePerformIO (hashNew (==) hashByteString) + +infixl 4 &: +l &: v = do + vars <- ask + return $ l (_Opts vars) v + +infixl 4 &<< +l &<< v = do + vars <- ask + io $ l (_Opts vars) v + +liftOpt l = do + vars <- ask + io $ l (_Opts vars) + + +defaultOpts = Opts + { adjustY = id + , fontIsDBCS = const $ requiredOpt usage "dbcs-pattern" + , dbcsPattern = Nothing + , readInputAFP = fail $ requiredOpt usage "input" + , openOutputAFP = fail $ requiredOpt usage "output" + , readFontlibAFP = const $ error "fontlib" -- calculated with the two fields below + , fontlibPaths = [C.pack "fontlib"] + , fontlibSuffix = C.empty + , cstrlenCheckUDC = checkUDC + , trnToSegments = dbcsHandler + , verbose = False + , showHelp = return () + } + where + checkUDC (cstr, len) = forM_ [0, 2..len-1] $ \off -> do + hi <- peekByteOff cstr off + when (isUDC hi) $ fail "UDC" + +usage :: String -> IO a +usage = showUsage options showInfo + +showInfo prg = + "Usage: " ++ prg ++ " -i FILE -o FILE\n" ++ + "( example: " ++ prg ++ " -a -s .afp -d M..T -i in.afp -o out.afp )" + +options :: [OptDescr (Opts -> Opts)] +options = + [ noArg "a" ["adjust"] "Adjust baseline offset" + (\o -> o { adjustY = \y -> (y * 13) `div` 16 }) + , reqArg "c" ["codepage"] "835|947" "UDC codepage (default: 835)" + setCodepage + , reqArg "d" ["dbcs-pattern"] "REGEXP" "DBCS font name pattern" + (\s o -> o { fontIsDBCS = setMatchDBCS (C.pack s) + , dbcsPattern = Just (C.pack s) }) + , reqArg "f" ["fontlib-path"] "PATH,PATH..." "Paths to font libraries" + (\s o -> o { fontlibPaths = C.split ',' (C.pack s) }) + , reqArg "i" ["input"] "FILE" "Input AFP file" + (\s o -> o { readInputAFP = readAFP s }) + , reqArg "o" ["output"] "FILE" "Output AFP file" + (\s o -> o { openOutputAFP = openBinaryFile s WriteMode }) + , reqArg "s" ["fontlib-suffix"] ".SUFFIX" "Font library file suffix" + (\s o -> o { fontlibSuffix = C.pack s }) + , noArg "v" ["verbose"] "Print progress information" + (\o -> o { verbose = True }) + , noArg "h" ["help"] "Show help" + (\o -> o { showHelp = usage "" }) + ] + where + _M__T = C.pack "M..T" + _NS__ = C.pack "NS.." + _NS = C.pack "NS" + setMatchDBCS s a + | s == _M__T = (C.length a >= 6) && ((C.index a 2 == 'M') || (C.index a 5 == 'T')) + | s == _NS__ = (C.length a >= 6) && ((C.index a 2 == 'N') || (C.index a 3 == 'S')) + | s == _NS = (C.length a >= 4) && ((C.index a 2 == 'N') || (C.index a 3 == 'S')) + | otherwise = (C.unpack a =~ C.unpack s) + setCodepage "835" = id + setCodepage "947" = \o -> o + { cstrlenCheckUDC = checkUDC + , trnToSegments = segment + -- if dbcsPattern is not set, set fontIsDBCS to (const True). + , fontIsDBCS = maybe (const True) + (const . fontIsDBCS $ o) + $ dbcsPattern o + } + setCodepage s = unsafePerformIO $ do + usage $ "invalid codepage:" ++ s + checkUDC cstrlen = do + str <- peekCStringLen cstrlen + unless (str =~ noUDC) $ fail "UDC" + noUDC = "^([\x00-\x7f]+|([\xA1-\xC5\xC9-\xF9].)+|(\xC6[^\xA1-\xFE])+)$" + segment = error "segment" + +type NChar = (N1, N1) +type FontField = ByteString +fromFontField = packA8 + +data Segment + = SegmentUDC + { segmentChar :: !NChar + , segmentReplace :: !NChar + } + | SegmentDBCS + { segmentChar :: !NChar + , segmentLength :: Int + } + | SegmentByte + { segmentByte :: [N1] + } + deriving (Show, Typeable) + +data Opts = Opts + { fontIsDBCS :: !(FontField -> Bool) + , dbcsPattern :: !(Maybe ByteString) + , adjustY :: !(I2 -> I2) + , readInputAFP :: !(IO [AFP_]) + , openOutputAFP :: !(IO Handle) + , readFontlibAFP :: !(ByteString -> IO [AFP_]) + , fontlibPaths :: !([ByteString]) + , fontlibSuffix :: !(ByteString) + , cstrlenCheckUDC :: !(CStringLen -> IO ()) + , trnToSegments :: FontField -> ByteString -> VarsIO ByteString + , verbose :: !(Bool) + , showHelp :: !(IO ()) + } deriving (Typeable) diff --git a/afp-validate.hs b/afp-validate.hs new file mode 100644 --- /dev/null +++ b/afp-validate.hs @@ -0,0 +1,33 @@ +module Main where +import OpenAFP +import System.Exit +import qualified Control.Exception as E (try, catch, throwIO) + +main :: IO () +main = do + args <- getArgs + if null args then error "Usage: afp-validate file.afp" else do + oks <- (`mapM` args) $ \file -> do + putStr $ file ++ ": " + rv <- E.try $ do + cs <- readAFP file + let (bpg, epg) = foldr count (0, 0) cs + count chunk (b, e) | chunk ~~ _BPG = (b+1, e) + count chunk (b, e) | chunk ~~ _EPG = (b, e+1) + count _ pair = pair + ok = (bpg > 0 && bpg == epg) + putStrLn $ concat + [ show bpg, " BPG, " + , show epg, " EPG (" + , if ok then "OK" else "FAIL" + , ")" + ] + return ok + case rv of + Right ok -> return ok + Left err -> do + print err + return False + if and oks + then exitWith ExitSuccess + else exitFailure diff --git a/afp2line.hs b/afp2line.hs new file mode 100644 --- /dev/null +++ b/afp2line.hs @@ -0,0 +1,213 @@ +module Main where +import OpenAFP +import Data.Monoid +import qualified Data.IntMap as IM +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Char8 as C +-- +-- import System.Posix.Resource +-- +-- __1GB__ :: Integer +-- __1GB__ = 1024 * 1024 * 1024 +-- +-- mkLimit :: Integer -> ResourceLimits +-- mkLimit x = ResourceLimits (ResourceLimit x) (ResourceLimit x) +-- +main :: IO () +main = do + -- setResourceLimit ResourceTotalMemory (mkLimit __1GB__) + -- setResourceLimit ResourceCoreFileSize (mkLimit 0) + + hSetBinaryMode stdout True + args <- getArgs + when (null args) $ do + putStrLn "Usage: afp2line input.afp ... > output.txt" + forM_ args $ \f -> do + ft <- guessFileType f + processFile ft f + +data FileType = F_ASCII | F_EBCDIC | F_AFP | F_PDF | F_Unknown deriving Show + +guessFileType :: FilePath -> IO FileType +guessFileType fn = do + fh <- openBinaryFile fn ReadMode + bs <- S.hGet fh 1 + hClose fh + return $ if S.null bs then F_Unknown else case C.head bs of + 'Z' -> F_AFP + '%' -> F_PDF + '1' -> F_ASCII + '0' -> F_ASCII + ' ' -> F_ASCII + '\xF0' -> F_EBCDIC + '\xF1' -> F_EBCDIC + '@' -> F_EBCDIC + _ -> F_Unknown + +processFile :: FileType -> FilePath -> IO () +processFile F_ASCII f = do + -- ...Look at each line's first byte to determine what to output... + return () +processFile F_AFP f = do + -- Read the first byte to determine its file type: + -- '1' indicates ASCII Plain Text line data + -- '\xF1' indicates EBCDIC line data + -- 'Z' indicates AFP file + -- '%' indicates PDF file + cs <- readAFP f + forM_ (splitRecords _PGD cs) $ \page -> do + page ..> + [ _PTX ... ptxDump + , _MCF ... mcfHandler + , _MCF1 ... mcf1Handler + ] + dumpPageContent +processFile t f = warn $ "Unknown file type: " ++ show t ++ " (" ++ f ++ ")" + +dumpPageContent :: IO () +dumpPageContent = do + MkPage pg <- readIORef _CurrentPage + writeIORef _CurrentPage mempty + if IM.null pg then return () else do + forM_ (IM.elems pg) $ \(MkLine line) -> do + writeIORef _CurrentColumn 0 + forM_ (IM.toAscList line) $ \(col, str) -> do + cur <- readIORef _CurrentColumn + S.putStr $ S.take (col - cur) _Spaces + S.putStr str + writeIORef _CurrentColumn (col + S.length str) + S.putStr _NewLine + S.putStr _NewPage + +_Spaces, _NewLine, _NewPage :: ByteString +_Spaces = S.replicate 4096 0x20 +_NewLine = C.pack "\r\n" +_NewPage = C.pack "\r\n\x0C\r\n" + +{-# NOINLINE _CurrentPage #-} +_CurrentPage :: IORef Page +_CurrentPage = unsafePerformIO $ newIORef mempty + +{-# NOINLINE _CurrentLine #-} +_CurrentLine :: IORef Int +_CurrentLine = unsafePerformIO $ newIORef 0 + +{-# NOINLINE _CurrentColumn #-} +_CurrentColumn :: IORef Int +_CurrentColumn = unsafePerformIO $ newIORef 0 + +{-# NOINLINE _MinFontSize #-} +_MinFontSize :: IORef Size +_MinFontSize = unsafePerformIO $ newIORef 0 + +lookupFontEncoding :: N1 -> IO (Maybe Encoding) +lookupFontEncoding = hashLookup _FontToEncoding + +insertFonts :: [(N1, ByteString)] -> IO () +insertFonts = mapM_ $ \(i, f) -> do + let (enc, sz) = fontInfoOf f + modifyIORef _MinFontSize $ \szMin -> case szMin of + 0 -> sz + _ -> min szMin sz + hashInsert _FontToEncoding i enc + +{-# NOINLINE _FontToEncoding #-} +_FontToEncoding :: HashTable N1 Encoding +_FontToEncoding = unsafePerformIO $ hashNew (==) fromIntegral + +-- | Record font Id to Name mappings in MCF's RLI and FQN chunks. +mcfHandler :: MCF -> IO () +mcfHandler r = do + readChunks r ..> + [ _MCF_T ... \mcf -> do + let cs = readChunks mcf + ids = [ t_rli (decodeChunk c) | c <- cs, c ~~ _T_RLI ] + fonts = [ t_fqn (decodeChunk c) | c <- cs, c ~~ _T_FQN ] + insertFonts (ids `zip` map packAStr fonts) + ] + +-- | Record font Id to Name mappings in MCF1's Data chunks. +mcf1Handler :: MCF1 -> IO () +mcf1Handler r = do + insertFonts + [ (mcf1_CodedFontLocalId mcf1, packA8 $ mcf1_CodedFontName mcf1) + | Record mcf1 <- readData r + ] + +ptxDump :: PTX -> IO () +ptxDump ptx = mapM_ ptxGroupDump . splitRecords _PTX_SCFL $ readChunks ptx + +-- A Page is a IntMap from line-number to a map from column-number to bytestring. +newtype Page = MkPage { fromPage :: IM.IntMap Line } deriving (Show, Monoid) +newtype Line = MkLine { lineStrs :: IM.IntMap S.ByteString } deriving Show + +insertText :: S.ByteString -> IO () +insertText str = do + ln <- readIORef _CurrentLine + col <- readIORef _CurrentColumn + modifyIORef _CurrentPage $ \(MkPage pg) -> MkPage $! case IM.lookup ln pg of + Nothing -> IM.insert ln (MkLine (IM.singleton col str)) pg + Just (MkLine im) -> IM.insert ln (MkLine (IM.insert col str im)) pg + +ptxGroupDump :: [PTX_] -> IO () +ptxGroupDump (scfl:cs) = do + let scflId = ptx_scfl (decodeChunk scfl) + curEncoding <- lookupFontEncoding scflId + cs ..> + [ _PTX_TRN ... \trn -> case curEncoding of + Just CP37 -> let bstr = packAStr' (ptx_trn trn) in do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP835 -> pack835 (ptx_trn trn) >>= \bstr -> do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP939 -> pack939 (ptx_trn trn) >>= \bstr -> do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP950 -> let bstr = packBuf (ptx_trn trn) in do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + _ -> fail "TRN without SCFL?" + , _PTX_BLN ... \_ -> do + writeIORef _CurrentColumn 0 + modifyIORef _CurrentLine (+1) + , _PTX_AMB ... movePosition Absolute _CurrentLine . ptx_amb + , _PTX_RMB ... movePosition Relative _CurrentLine . ptx_rmb + , _PTX_AMI ... movePosition Absolute _CurrentColumn . ptx_ami + , _PTX_RMI ... movePosition Relative _CurrentColumn . ptx_rmi + ] + +data Position = Absolute | Relative + +movePosition :: Position -> IORef Int -> N2 -> IO () +movePosition p ref n = do + minSize <- readIORef _MinFontSize + let offset = fromEnum n `div` minSize + case p of + Absolute -> writeIORef ref offset + Relative -> modifyIORef ref (+ offset) + + +packAStr' :: AStr -> S.ByteString +packAStr' astr = S.map (ebc2ascIsPrintW8 !) (packBuf astr) + +{-# INLINE pack835 #-} +{-# INLINE pack939 #-} +pack835, pack939 :: NStr -> IO S.ByteString +pack835 = packWith convert835to950 +pack939 = packWith convert939to932 + +{-# INLINE packWith #-} +packWith :: (Int -> Int) -> NStr -> IO S.ByteString +packWith f nstr = S.unsafeUseAsCStringLen (packBuf nstr) $ \(src, len) -> S.create len $ \target -> do + let s = castPtr src + let t = castPtr target + forM_ [0..(len `div` 2)-1] $ \i -> do + hi <- peekByteOff s (i*2) :: IO Word8 + lo <- peekByteOff s (i*2+1) :: IO Word8 + let ch = f (fromEnum hi * 256 + fromEnum lo) + (hi', lo') = ch `divMod` 256 + pokeByteOff t (i*2) (toEnum hi' :: Word8) + pokeByteOff t (i*2+1) (toEnum lo' :: Word8)