X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FConverter.hs;h=4fb0ec309f6608bf12494c3c4f7559bc31a73ddc;hb=8876aca404b4c111461b7582bb772d219babd3aa;hp=6f16e316aaa99984aacb51dae201b4169a3de61b;hpb=a937c158a55c8d80c9c35777fcb104767450e8dd;p=hs-java.git diff --git a/JVM/Converter.hs b/JVM/Converter.hs index 6f16e31..4fb0ec3 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -1,27 +1,40 @@ {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-} -module JVM.Converter where +-- | Functions to convert from low-level .class format representation and +-- high-level Java classes, methods etc representation +module JVM.Converter + (parseClass, parseClassFile, + convertClass, classFile, + encodeClass, + methodByName, + attrByName, + methodCode + ) + where +import Control.Monad.Exception import Data.List import Data.Word import Data.Bits import Data.Binary -import Data.Char -import Data.String import qualified Data.ByteString.Lazy as B import Data.Array import qualified Data.Set as S import qualified Data.Map as M -import Debug.Trace - import JVM.ClassFile import JVM.Types +import JVM.Exceptions -decompile :: B.ByteString -> Class -decompile bstr = convertClass $ decode bstr +-- | Parse .class file data +parseClass :: B.ByteString -> Class +parseClass bstr = convertClass $ decode bstr -decompileFile :: FilePath -> IO Class -decompileFile path = convertClass `fmap` decodeFile path +-- | Parse class data from file +parseClassFile :: FilePath -> IO Class +parseClassFile path = convertClass `fmap` decodeFile path + +encodeClass :: Class -> B.ByteString +encodeClass cls = encode $ classFile cls convertClass :: ClassFile -> Class convertClass (ClassFile {..}) = @@ -37,6 +50,109 @@ convertClass (ClassFile {..}) = methods = map (convertMethod pool) classMethods, classAttrs = convertAttrs pool classAttributes } +classFile :: Class -> ClassFile +classFile (Class {..}) = ClassFile { + magic = 0xCAFEBABE, + minorVersion = 0, + majorVersion = 50, + constsPoolSize = fromIntegral (length poolInfo + 1), + constsPool = poolInfo, + accessFlags = access2word16 classAccess, + thisClass = force "this" $ poolClassIndex poolInfo this, + superClass = case super of + Just s -> force "super" $ poolClassIndex poolInfo s + Nothing -> 0, + interfacesCount = fromIntegral (length implements), + interfaces = map (force "ifaces" . poolIndex poolInfo) implements, + classFieldsCount = fromIntegral (length fields), + classFields = map (fieldInfo poolInfo) fields, + classMethodsCount = fromIntegral (length methods), + classMethods = map (methodInfo poolInfo) methods, + classAttributesCount = fromIntegral (M.size classAttrs), + classAttributes = map (attrInfo poolInfo) (M.assocs classAttrs) } + where + poolInfo = toCPInfo constantPool + +toCPInfo :: Pool -> [CpInfo] +toCPInfo pool = result + where + result = map cpInfo $ elems pool + + cpInfo (CClass name) = CONSTANT_Class (force "class" $ poolIndex result name) + cpInfo (CField cls name) = + CONSTANT_Fieldref (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name) + cpInfo (CMethod cls name) = + CONSTANT_Methodref (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name) + cpInfo (CIfaceMethod cls name) = + CONSTANT_InterfaceMethodref (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name) + cpInfo (CString s) = CONSTANT_String (force "string" $ poolIndex result s) + cpInfo (CInteger x) = CONSTANT_Integer x + cpInfo (CFloat x) = CONSTANT_Float x + cpInfo (CLong x) = CONSTANT_Long (fromIntegral x) + cpInfo (CDouble x) = CONSTANT_Double x + cpInfo (CNameType n t) = + CONSTANT_NameAndType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t) + cpInfo (CUTF8 s) = CONSTANT_Utf8 (fromIntegral $ B.length s) s + cpInfo (CUnicode s) = CONSTANT_Unicode (fromIntegral $ B.length s) s + +-- | Find index of given string in the list of constants +poolIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16 +poolIndex list name = case findIndex test list of + Nothing -> throw (NoItemInPool name) + Just i -> return $ fromIntegral $ i+1 + where + test (CONSTANT_Utf8 _ s) | s == name = True + test (CONSTANT_Unicode _ s) | s == name = True + test _ = False + +-- | Find index of given string in the list of constants +poolClassIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16 +poolClassIndex list name = case findIndex checkString list of + Nothing -> throw (NoItemInPool name) + Just i -> case findIndex (checkClass $ fromIntegral $ i+1) list of + Nothing -> throw (NoItemInPool $ i+1) + Just j -> return $ fromIntegral $ j+1 + where + checkString (CONSTANT_Utf8 _ s) | s == name = True + checkString (CONSTANT_Unicode _ s) | s == name = True + checkString _ = False + + checkClass i (CONSTANT_Class x) | i == x = True + checkClass _ _ = False + +poolNTIndex list x@(NameType n t) = do + ni <- poolIndex list n + ti <- poolIndex list (byteString t) + case findIndex (check ni ti) list of + Nothing -> throw (NoItemInPool x) + Just i -> return $ fromIntegral (i+1) + where + check ni ti (CONSTANT_NameAndType n' t') + | (ni == n') && (ti == t') = True + check _ _ _ = False + +fieldInfo :: [CpInfo] -> Field -> FieldInfo +fieldInfo pool (Field {..}) = FieldInfo { + fieldAccessFlags = access2word16 fieldAccess, + fieldNameIndex = force "field name" $ poolIndex pool fieldName, + fieldSignatureIndex = force "signature" $ poolIndex pool (encode fieldSignature), + fieldAttributesCount = fromIntegral (M.size fieldAttrs), + fieldAttributes = map (attrInfo pool) (M.assocs fieldAttrs) } + +methodInfo :: [CpInfo] -> Method -> MethodInfo +methodInfo pool (Method {..}) = MethodInfo { + methodAccessFlags = access2word16 methodAccess, + methodNameIndex = force "method name" $ poolIndex pool methodName, + methodSignatureIndex = force "method sig" $ poolIndex pool (encode methodSignature), + methodAttributesCount = fromIntegral (M.size methodAttrs), + methodAttributes = map (attrInfo pool) (M.assocs methodAttrs) } + +attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo +attrInfo pool (name, value) = AttributeInfo { + attributeName = force "attr name" $ poolIndex pool name, + attributeLength = fromIntegral (B.length value), + attributeValue = value } + constantPoolArray :: [CpInfo] -> Pool constantPoolArray list = pool where @@ -62,8 +178,6 @@ constantPoolArray list = pool convert (CONSTANT_Utf8 _ bs) = CUTF8 bs convert (CONSTANT_Unicode _ bs) = CUnicode bs -className' x = trace ("Class name: " ++ show x) B.empty - convertAccess :: Word16 -> Access convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [ ACC_PUBLIC, @@ -78,6 +192,12 @@ convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] ACC_INTERFACE, ACC_ABSTRACT ] +access2word16 :: Access -> Word16 +access2word16 fs = bitsOr $ map toBit $ S.toList fs + where + bitsOr = foldl (.|.) 0 + toBit f = 1 `shiftL` (fromIntegral $ fromEnum f) + convertField :: Pool -> FieldInfo -> Field convertField pool (FieldInfo {..}) = Field { fieldAccess = convertAccess fieldAccessFlags, @@ -98,14 +218,19 @@ convertAttrs pool attrs = M.fromList $ map go attrs go (AttributeInfo {..}) = (getString $ pool ! attributeName, attributeValue) +-- | Try to get class method by name methodByName :: Class -> B.ByteString -> Maybe Method methodByName cls name = find (\m -> methodName m == name) (methods cls) +-- | Try to get object attribute by name attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString attrByName x name = M.lookup name (attributes x) -methodCode :: Class -> B.ByteString -> Maybe B.ByteString +-- | Try to get Code for class method (no Code for interface methods) +methodCode :: Class + -> B.ByteString -- ^ Method name + -> Maybe B.ByteString methodCode cls name = do method <- methodByName cls name attrByName method "Code"