packages feed

OpenAFP-Utils (empty) → 1.1

raw patch · 14 files changed

+1768/−0 lines, 14 filesdep +OpenAFPdep +basedep +bytestringsetup-changed

Dependencies added: OpenAFP, base, bytestring, containers, directory, filepath, haskell98, regex-base, regex-posix, uconv, xhtml

Files

+ LICENSE view
@@ -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.
+ OpenAFP-Utils.cabal view
@@ -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
+ Setup.lhs view
@@ -0,0 +1,10 @@+#!/usr/bin/env runghc+\begin{code}++module Main where+import Distribution.Simple++main :: IO ()+main = defaultMain++\end{code}
+ afp-dump.hs view
@@ -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 "<?xml version=\"1.0\"?>"+    put "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"+    put "<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en\" xml:lang=\"en\">"+    put $ htmlPage input+    put "<ol class=\"top\">"+    mapM_ (hPutStrLn fh . (`withChunk` (showHtmlFragment . recHtml . recView))) cs+    put "</ol></body></html>"+    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 " &mdash; " +++ 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)
+ afp-page.hs view
@@ -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  " }+
+ afp-replace.hs view
@@ -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
+ afp-scanudc.hs view
@@ -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")
+ afp-split-scb.hs view
@@ -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)
+ afp-split-tcb.hs view
@@ -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+
+ afp-split.hs view
@@ -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)
+ afp-type.hs view
@@ -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
+ afp-udcfix.hs view
@@ -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)
+ afp-validate.hs view
@@ -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
+ afp2line.hs view
@@ -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)