Permalink
Browse files

* Initial checkin of OpenAFP-Utils 1.3.

  • Loading branch information...
0 parents commit 9fc9bf103d741bd170fe2a8fd06221dfa8f27f53 唐鳳 committed Nov 25, 2010
Showing with 2,239 additions and 0 deletions.
  1. +20 −0 LICENSE
  2. +71 −0 OpenAFP-Utils.cabal
  3. +10 −0 Setup.lhs
  4. +222 −0 afp-dump.hs
  5. +101 −0 afp-olndump.hs
  6. +48 −0 afp-page.hs
  7. +263 −0 afp-replace.hs
  8. +84 −0 afp-scanudc.hs
  9. +55 −0 afp-split-scb.hs
  10. +124 −0 afp-split-tcb.hs
  11. +40 −0 afp-split.hs
  12. +13 −0 afp-type.hs
  13. +583 −0 afp-udcfix.hs
  14. +33 −0 afp-validate.hs
  15. +218 −0 afp2line.hs
  16. +354 −0 afp2line2pdf.hs
20 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.
@@ -0,0 +1,71 @@
+Name: OpenAFP-Utils
+Version: 1.3
+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
+Cabal-Version: >= 1.2
+
+Executable afp2line2pdf
+ Main-is: afp2line2pdf.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base, line2pdf >= 0.0.7
+ Extensions: StandaloneDeriving, GeneralizedNewtypeDeriving, ImplicitParams,
+ ExistentialQuantification, PatternGuards
+
+Executable afp-olndump
+ Main-is: afp-olndump.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base, bytestring, containers, binary
+
+Executable afp-dump
+ Main-is: afp-dump.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base, bytestring, containers, uconv, xhtml
+ Extensions: DeriveDataTypeable, PatternGuards
+
+Executable afp-page
+ Main-is: afp-page.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base
+
+Executable afp-replace
+ Main-is: afp-replace.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base
+ Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards
+
+Executable afp-scanudc
+ Main-is: afp-scanudc.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base>=3 && <4, directory
+ Extensions: BangPatterns, PatternGuards
+
+Executable afp-split
+ Main-is: afp-split.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base
+
+Executable afp-split-scb
+ Main-is: afp-split-scb.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base
+
+Executable afp-split-tcb
+ Main-is: afp-split-tcb.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base, filepath
+ Extensions: ImplicitParams
+
+Executable afp-type
+ Main-is: afp-type.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base
+
+Executable afp-udcfix
+ Main-is: afp-udcfix.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base, regex-base, regex-posix
+ Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, PatternGuards, RankNTypes
+
+Executable afp-validate
+ Main-is: afp-validate.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base>=3 && <4
+
+Executable afp2line
+ Main-is: afp2line.hs
+ Build-depends: OpenAFP >= 1.2, haskell98, base
+ Extensions: GeneralizedNewtypeDeriving
@@ -0,0 +1,10 @@
+#!/usr/bin/env runghc
+\begin{code}
+
+module Main where
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
+
+\end{code}
@@ -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)
Oops, something went wrong.

0 comments on commit 9fc9bf1

Please sign in to comment.