module Jvm.BinaryClass where
import Jvm.Data.ClassFormat
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BS
import Control.Monad
import Data.Word
import Data.Int
import Data.Bits
instance Binary ClassFile where
put (ClassFile mg mnv mjv tam_cp lst_cp flgs ths spr tam_if lst_if tam_fd lst_fd tam_mth lst_mth tam_attr lst_attr)
= put mg >>
put mnv >>
put mjv >>
put (fromInt2Word16 tam_cp) >>
mapM_ put lst_cp >>
put flgs >>
put ths >>
put spr >>
put (fromInt2Word16 tam_if) >>
mapM_ put lst_if >>
put (fromInt2Word16 tam_fd) >>
mapM_ put lst_fd >>
put (fromInt2Word16 tam_mth) >>
mapM_ put lst_mth >>
put (fromInt2Word16 tam_attr) >>
mapM_ put lst_attr
get = do mg <- get :: Get Magic
mnv <- get :: Get MinorVersion
mjv <- get :: Get MajorVersion
wtam_cp <- getWord16
let tam_cp = fromWord162Int wtam_cp
lst_cp <- getMany $ tam_cp1
flgs <- get :: Get AccessFlags
ths <- get :: Get ThisClass
spr <- get :: Get SuperClass
wtam_if <- getWord16
let tam_if = fromWord162Int wtam_if
lst_if <- getMany tam_if
wtam_fd <- getWord16
let tam_fd = fromWord162Int wtam_fd
lst_fd <- getMany tam_fd
wtam_mth <- getWord16
let tam_mth = fromWord162Int wtam_mth
lst_mth <- getMany tam_mth
wtam_attr <- getWord16
let tam_attr = fromWord162Int wtam_attr
lst_attr <- getMany tam_attr
return $ ClassFile mg mnv mjv tam_cp lst_cp flgs ths spr tam_if lst_if tam_fd lst_fd tam_mth lst_mth tam_attr lst_attr
instance Binary Magic where
put (Magic) = put (202::Word8) >> put (254::Word8) >> put (186::Word8) >> put (190::Word8)
get = do ca <- getWord8
fe <- getWord8
ba <- getWord8
be <- getWord8
return Magic
instance Binary MinorVersion where
put (MinorVersion i)
= put $ fromInt2Word16 i
get = do str <- getWord16
return $ MinorVersion $ fromWord162Int str
instance Binary MajorVersion where
put (MajorVersion i) = put $ fromInt2Word16 i
get = do str <- getWord16
return $ MajorVersion $ fromWord162Int str
instance Binary CP_Info where
put (Class_Info tag_cp index_cp str)
= put tag_cp >> put (fromInt2Word16 index_cp)
put (FieldRef_Info tag_cp index_name_cp index_nameandtype_cp str)
= put tag_cp >> put (fromInt2Word16 index_name_cp) >> put (fromInt2Word16 index_nameandtype_cp)
put (MethodRef_Info tag_cp index_name_cp index_nameandtype_cp _)
= put tag_cp >> put (fromInt2Word16 index_name_cp) >> put (fromInt2Word16 index_nameandtype_cp)
put (InterfaceMethodRef_Info tag_cp index_name_cp index_nameandtype_cp _)
= put tag_cp >> put (fromInt2Word16 index_name_cp) >> put (fromInt2Word16 index_nameandtype_cp)
put (String_Info tag_cp index_cp _)
= put tag_cp >> put (fromInt2Word16 index_cp)
put (Integer_Info tag_cp numi_cp _)
= put tag_cp >> put (fromInt2Word32 numi_cp)
put (Float_Info tag_cp numf_cp _)
= put tag_cp >> put (fromFloat2Word32 numf_cp)
put (Long_Info tag_cp numi_l1_cp numi_l2_cp _)
= put tag_cp >> put (fromInt2Word32 numi_l1_cp) >> put (fromInt2Word32 numi_l2_cp)
put (Double_Info tag_cp numi_d1_cp numi_d2_cp _)
= put tag_cp >> put (fromInt2Word32 numi_d1_cp) >> put (fromInt2Word32 numi_d2_cp)
put (NameAndType_Info tag_cp index_name_cp index_descr_cp _)
= put tag_cp >> put (fromInt2Word16 index_name_cp) >> put (fromInt2Word16 index_descr_cp)
put (Utf8_Info tag_cp tam_cp cad_cp _)
= put tag_cp >> put (fromInt2Word16 tam_cp) >> mapM_ put cad_cp
get = do tag <- get :: Get Tag
case tag of
TagClass
-> do wind <- getWord16
let ind = fromWord162Int wind
return $ Class_Info tag ind ""
TagFieldRef
-> do wind1 <- getWord16
wind2 <- getWord16
let ind1 = fromWord162Int wind1
ind2 = fromWord162Int wind2
return $ FieldRef_Info tag ind1 ind2 ""
TagMethodRef
-> do wind1 <- getWord16
wind2 <- getWord16
let ind1 = fromWord162Int wind1
ind2 = fromWord162Int wind2
return $ MethodRef_Info tag ind1 ind2 ""
TagInterfaceMethodRef
-> do wind1 <- getWord16
wind2 <- getWord16
let ind1 = fromWord162Int wind1
ind2 = fromWord162Int wind2
return $ InterfaceMethodRef_Info tag ind1 ind2 ""
TagString
-> do wind <- getWord16
let ind = fromWord162Int wind
return $ String_Info tag ind ""
TagInteger
-> do wnum <- getWord32
let num = fromWord322Int wnum
return $ Integer_Info tag num ""
TagFloat
-> do wnum <- getWord32
let num = fromWord322Float wnum
return $ Float_Info tag num ""
TagLong
-> do wnum1 <- getWord32
wnum2 <- getWord32
let num1 = fromWord322Int wnum1
num2 = fromWord322Int wnum2
return $ Long_Info tag num1 num2 ""
TagDouble
-> do wnum1 <- getWord32
wnum2 <- getWord32
let num1 = fromWord322Int wnum1
num2 = fromWord322Int wnum2
return $ Double_Info tag num1 num2 ""
TagNameAndType
-> do wnum1 <- getWord16
wnum2 <- getWord16
let num1 = fromWord162Int wnum1
num2 = fromWord162Int wnum2
return $ NameAndType_Info tag num1 num2 ""
TagUtf8
-> do wnum <- getWord16
let num = fromWord162Int wnum
lst <- getMany num
return $ Utf8_Info tag num lst ""
instance Binary Tag where
put (TagClass) = put (7 ::Word8)
put (TagFieldRef) = put (9 ::Word8)
put (TagMethodRef) = put (10::Word8)
put (TagInterfaceMethodRef) = put (11::Word8)
put (TagString) = put (8 ::Word8)
put (TagInteger) = put (3 ::Word8)
put (TagFloat) = put (4 ::Word8)
put (TagLong) = put (5 ::Word8)
put (TagDouble) = put (6 ::Word8)
put (TagNameAndType) = put (12::Word8)
put (TagUtf8) = put (1 ::Word8)
get = do num <- get::Get Word8
let val = fromWord82Int num
let tag = case val of
7 -> TagClass
9 -> TagFieldRef
10 -> TagMethodRef
11 -> TagInterfaceMethodRef
8 -> TagString
3 -> TagInteger
4 -> TagFloat
5 -> TagLong
6 -> TagDouble
12 -> TagNameAndType
1 -> TagUtf8
_ -> error $ "Error: Unknow Tag " ++ show val
return tag
instance Binary AccessFlags where
put (AccessFlags lst) = do
let flag = if null lst
then 0
else foldl1 (.+.) lst
put $ fromInt2Word16 flag
get = do wmask <- getWord16
let mask = fromWord162Int wmask
lst = filter (bitsSet mask) [ acc_Public
, acc_Private
, acc_Protected
, acc_Static
, acc_Final
, acc_Super_Synchronized
, acc_Volatile_Bridge
, acc_Transient_Varargs
, acc_Native
, acc_Interface
, acc_Abstract
, acc_Strict
, acc_Synthetic
, acc_Annotation
, acc_Enum]
return $ AccessFlags lst
instance Binary ThisClass where
put (ThisClass i) = put $ fromInt2Word16 i
get = do wnum <- get :: Get Word16
let num = fromWord162Int wnum
return $ ThisClass num
instance Binary SuperClass where
put (SuperClass i) = put $ fromInt2Word16 i
get = do wnum <- get :: Get Word16
let num = fromWord162Int wnum
return $ SuperClass num
instance Binary Interface where
put (Interface i) = put $ fromInt2Word16 i
get = do wiif <- get :: Get Word16
let iif = fromWord162Int wiif
return $ Interface iif
instance Binary Field_Info where
put (Field_Info accs inam idsr tam lst_attr)
= put accs >> put (fromInt2Word16 inam) >> put (fromInt2Word16 idsr) >> put (fromInt2Word16 tam) >> mapM_ put lst_attr
get = do accs <- get :: Get AccessFlags
winam <- getWord16
widsr <- getWord16
wtam <- getWord16
let inam = fromWord162Int winam
let idsr = fromWord162Int widsr
let tam_attr = fromWord162Int wtam
lst_attr <- getMany tam_attr
return $ Field_Info accs inam idsr tam_attr lst_attr
instance Binary Method_Info where
put (Method_Info accs inam idsr tam_attr lst_attr)
= put accs >> put (fromInt2Word16 inam) >> put (fromInt2Word16 idsr) >> put (fromInt2Word16 tam_attr) >> mapM_ put lst_attr
get = do accs <- get :: Get AccessFlags
winam <- getWord16
widsr <- getWord16
wtam <- getWord16
let inam = fromWord162Int winam
let idsr = fromWord162Int widsr
let tam_attr = fromWord162Int wtam
lst_attr <- getMany tam_attr
return $ Method_Info accs inam idsr tam_attr lst_attr
instance Binary Attribute_Info where
put (AttributeGeneric inam tam_all rest_attr)
= put (fromInt2Word16 inam) >> put (fromInt2Word32 tam_all) >> putLazyByteString rest_attr
put (AttributeConstantValue inam tam_all ival)
= put (fromInt2Word16 inam) >> put (fromInt2Word32 tam_all ) >> put (fromInt2Word16 ival)
put (AttributeCode inam tam_all mlen_stack mlen_local tam_code lst_code tam_ex lst_ex tam_attr lst_attr)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all) >>
put (fromInt2Word16 mlen_stack) >>
put (fromInt2Word16 mlen_local) >>
put (fromInt2Word32 tam_code) >>
mapM_ (\cod -> putWord8 (fromInt2Word8 cod)) lst_code >>
put (fromInt2Word16 tam_ex) >>
mapM_ (\(e1,e2,e3,e4) -> put (fromInt2Word16 e1) >> put (fromInt2Word16 e2) >> put (fromInt2Word16 e3) >> put (fromInt2Word16 e4)) lst_ex >>
put (fromInt2Word16 tam_attr) >>
mapM_ put lst_attr
put (AttributeExceptions inam tam_all tam_num_ex lst_ex)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all) >>
put (fromInt2Word16 tam_num_ex) >>
mapM_ (\ind -> putWord8 (fromInt2Word8 ind)) lst_ex
put (AttributeInnerClasses inam tam_all tam_classes lst_classes)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all) >>
put (fromInt2Word16 tam_classes) >>
mapM_ (\(incl,outcl,innm,inflg) -> put (fromInt2Word16 incl) >>
put (fromInt2Word16 outcl) >>
put (fromInt2Word16 innm) >>
put inflg) lst_classes
put (AttributeSynthetic inam tam_all)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all)
put (AttributeSourceFile inam tam_all ind_src)
= put (fromInt2Word16 inam) >> put (fromInt2Word32 tam_all) >> put (fromInt2Word16 ind_src)
put (AttributeLineNumberTable inam tam_all tam_table lst_line)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all) >>
put (fromInt2Word16 tam_table) >>
mapM_ (\(e1,e2) -> put (fromInt2Word16 e1) >> put (fromInt2Word16 e2)) lst_line
put (AttributeLocalVariableTable inam tam_all tam_var lst_var)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all) >>
put (fromInt2Word16 tam_var) >>
mapM_ (\(e1,e2,e3,e4,e5) -> put (fromInt2Word16 e1) >> put (fromInt2Word16 e2) >> put (fromInt2Word16 e3) >> put (fromInt2Word16 e4) >> put (fromInt2Word16 e5)) lst_var
put (AttributeDeprecated inam tam_all)
= put (fromInt2Word16 inam) >>
put (fromInt2Word32 tam_all)
get = do winam <- getWord16
wtam_all <- getWord32
let inam = fromWord162Int winam
tam_all = fromWord322Int wtam_all
rest_attr <- getLazyByteString $ toInt64 tam_all
return $ AttributeGeneric inam tam_all rest_attr
type Tupla5Int = [(Int, Int, Int, Int, Int)]
type Tupla2Int = [(Int, Int)]
type Tupla4Int = [(Int, Int, Int, Int)]
type ListaInt = [Int]
type ConstantPool_Count = Int
type Interfaces_Count = Int
type Fields_Count = Int
type Methods_Count = Int
type Attributes_Count = Int
type Index_Constant_Pool = Int
infixl 5 .+.
(.+.) :: Int -> Int -> Int
a .+. b = a .|. b
bitsSet :: Int -> Int -> Bool
bitsSet mask i
= (mask .&. i == i)
toInt64 :: Int -> Int64
toInt64 = read.show
getWord16 = get :: Get Word16
getWord32 = get :: Get Word32
fromWord162Int :: Word16 -> Int
fromWord162Int = read.show
fromWord82Int :: Word8 -> Int
fromWord82Int = read.show
fromWord322Int :: Word32 -> Int
fromWord322Int = read.show
fromWord322Float :: Word32 -> Float
fromWord322Float = read.show
fromInt2Word8 :: Int -> Word8
fromInt2Word8 = read.show
fromInt2Word16 :: Int -> Word16
fromInt2Word16 = read.show
fromInt2Word32 :: Int -> Word32
fromInt2Word32 = read.show
fromFloat2Word32 :: Float -> Word32
fromFloat2Word32 = read.show
getMany :: Binary a => Int -> Get [a]
getMany n = go [] n
where
go xs 0 = return $! reverse xs
go xs i = do x <- get
x `seq` go (x:xs) (i1)
getListAttr cp_infos 0 str = ([],str,toInt64 0)
getListAttr cp_infos n str
= let (winam,rs1,n1) = runGetState (get :: Get Word16) str (toInt64 0)
inam = fromWord162Int winam
(wtam,rs2,n2) = runGetState (get :: Get Word32) rs1 (toInt64 0)
tam = fromWord322Int wtam
(rest,rs3,n3) = runGetState (getLazyByteString (toInt64 tam)) rs2 (toInt64 0)
attr_generic = AttributeGeneric inam tam rest
attr_specific = fChgAttr cp_infos attr_generic
in let (lstn, rsn, nn) = getListAttr cp_infos (n1) rs3 in (attr_specific : lstn, rsn, nn)
getListExCod 0 str = ([],str)
getListExCod n str
= let (wstart_pc , rs1, n1) = runGetState (get :: Get Word16) str (toInt64 0)
(wend_pc , rs2, n2) = runGetState (get :: Get Word16) rs1 (toInt64 0)
(whandler_pc, rs3, n3) = runGetState (get :: Get Word16) rs2 (toInt64 0)
(wcatch_type, rs4, n4) = runGetState (get :: Get Word16) rs3 (toInt64 0)
start_pc = fromWord162Int wstart_pc
end_pc = fromWord162Int wend_pc
handler_pc = fromWord162Int whandler_pc
catch_type = fromWord162Int wcatch_type
in let (lst, r) = getListExCod (n1) rs4 in ((start_pc,end_pc,handler_pc,catch_type):lst, r)
getListTuplaInner 0 str = ([],str)
getListTuplaInner n str
= let (wincl , rs1, n1) = runGetState (get :: Get Word16) str (toInt64 0)
(woutcl, rs2, n2) = runGetState (get :: Get Word16) rs1 (toInt64 0)
(winnm , rs3, n3) = runGetState (get :: Get Word16) rs2 (toInt64 0)
(inflg, rs4, n4) = runGetState (get :: Get AccessFlags) rs3 (toInt64 0)
incl = fromWord162Int wincl
outcl = fromWord162Int woutcl
innm = fromWord162Int winnm
in let (lst, r) = getListTuplaInner (n1) rs4 in ((incl,outcl,innm,inflg):lst, r)
getListEx 0 str = ([],str)
getListEx n str
= let (wcod, str', no) = runGetState (get :: Get Word16) str (toInt64 0)
ex = fromWord162Int wcod
in let (lst,r) = getListEx (n1) str' in (ex:lst, r)
getListCode 0 str = ([],str)
getListCode n str
= let (wcod, str', no) = runGetState (get :: Get Word8) str (toInt64 0)
cod = fromWord82Int wcod
in let (lst,r) = getListCode (n1) str' in (cod:lst, r)
getListLineNumber 0 str = ([], str)
getListLineNumber n str
= let (wstart_pc, str1, n1) = runGetState (get :: Get Word16) str (toInt64 0)
start_pc = fromWord162Int wstart_pc
(wline_number, str2, n2) = runGetState (get :: Get Word16) str1 (toInt64 0)
line_number = fromWord162Int wline_number
in let (lst,r) = getListLineNumber (n1) str2 in ((start_pc,line_number):lst, r)
getNameCP_Utf8 :: Int -> CP_Infos -> String
getNameCP_Utf8 index cp_infos = cad_cp $ cp_infos !! (index1)
fChgAttr :: CP_Infos -> Attribute_Info -> Attribute_Info
fChgAttr cp_infos (AttributeGeneric inam tam rbs)
= case getNameCP_Utf8 inam cp_infos of
"SourceFile"
-> let (wisrc, rest, n) = runGetState (get :: Get Word16) rbs (toInt64 0)
isrc = fromWord162Int wisrc
in AttributeSourceFile inam tam isrc
"Code"
-> let (wstack , rs1, n1) = runGetState (get :: Get Word16) rbs (toInt64 0)
stack = fromWord162Int wstack
(wlocal , rs2, n2) = runGetState (get :: Get Word16) rs1 (toInt64 0)
local = fromWord162Int wlocal
(wtam_code, rs3, n3) = runGetState (get :: Get Word32) rs2 (toInt64 0)
tam_code = fromWord322Int wtam_code
(lst_code, rs4) = getListCode tam_code rs3
(wtam_ex, rs5, n4) = runGetState (get :: Get Word16) rs4 (toInt64 0)
tam_ex = fromWord162Int wtam_ex
(lst_ex, rs6) = getListExCod tam_ex rs5
(wtam_attr,rs7,n5) = runGetState (get :: Get Word16) rs6 (toInt64 0)
tam_attr = fromWord162Int wtam_attr
(lst_attr,rs8, n6) = getListAttr cp_infos tam_attr rs7
in AttributeCode inam tam stack local tam_code lst_code tam_ex lst_ex tam_attr lst_attr
"LineNumberTable"
-> let (wntable, rs0, n0) = runGetState (get :: Get Word16) rbs (toInt64 0)
ntable = fromWord162Int wntable
(lst_line, rs1) = getListLineNumber ntable rs0
in AttributeLineNumberTable inam tam ntable lst_line
"Exceptions"
-> let (wntable, rs0, n0) = runGetState (get :: Get Word16) rbs (toInt64 0)
ntable = fromWord162Int wntable
(lst_ex, rs1) = getListEx ntable rs0
in AttributeExceptions inam tam ntable lst_ex
"Synthetic"
-> AttributeSynthetic inam tam
"InnerClasses"
-> let (wntable, rs0, n0) = runGetState (get :: Get Word16) rbs (toInt64 0)
ntable = fromWord162Int wntable
(lst_classes, rs1) = getListTuplaInner ntable rs0
in AttributeInnerClasses inam tam ntable lst_classes
"Deprecated"
-> AttributeDeprecated inam tam
otherwise
-> AttributeGeneric inam tam rbs
chgAttrG_Fields :: ClassFile -> ClassFile
chgAttrG_Fields cf = cf{array_fields = new_array_fields}
where new_array_fields = map fun $ array_fields cf
fun fld = fld{array_attr_fi = new_fi fld}
new_fi fld' = map (fChgAttr (array_cp cf)) $ array_attr_fi fld'
chgAttrG_Methods :: ClassFile -> ClassFile
chgAttrG_Methods cf = cf{array_methods = new_array_methods}
where new_array_methods = map fun $ array_methods cf
fun mth = mth{array_attr_mi = new_mi mth}
new_mi mth' = map (fChgAttr (array_cp cf)) $ array_attr_mi mth'
chgAttrG_ClassFile :: ClassFile -> ClassFile
chgAttrG_ClassFile cf = cf{array_attributes = new_array_attributes}
where new_array_attributes = map (fChgAttr (array_cp cf)) $ array_attributes cf
encodeClassFile :: FilePath -> ClassFile -> IO ()
encodeClassFile = encodeFile
decodeClassFile :: FilePath -> IO ClassFile
decodeClassFile fn = do
obj <- decodeFile fn :: IO ClassFile
let obj1 = chgAttrG_ClassFile obj
obj2 = chgAttrG_Methods obj1
obj3 = chgAttrG_Fields obj2
return obj3