Skip to content

Commit 7ae61d9

Browse files
RayZopfRayZopf
committed
patch files for json support/string conversion
adressing issues - https://code.google.com/p/lslforge/issues/detail?id=40 (llJson* Not implemented) - (redone) https://code.google.com/p/lslforge/issues/detail?id=18 (Lslforge corrupts data during optimization) also update LSLForge cabal given patch was not used; - changed version number - added dependency json (== 0.7.*) blame [pells...@gmail.com](https://code.google.com/u/101374969631348043816/) taken from RayZopf/LSLForge_patched@8e8b8b1 RayZopf/LSLForge_patched@27ea23d RayZopf/LSLForge_patched@af9d403
1 parent e015c14 commit 7ae61d9

File tree

3 files changed

+227
-15
lines changed

3 files changed

+227
-15
lines changed

‎lslforge/haskell/LslForge.cabal‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
Name: LSLForge
2-
version: 0.1.6
2+
version: 0.1.6.1
33
Synopsis: An execution and testing framework for the Linden Scripting Language (LSL)
44
Description:
55
Provides a framework for executing Linden Scripting Language scripts offline,
@@ -11,7 +11,7 @@ Homepage: http:/lslforge.googlecode.com/
1111
License: BSD3
1212
License-file: LICENSE
1313
Category: Language
14-
Copyright: Copyright (c) Robert Greayer 2008-2010, Others 2011-2012
14+
Copyright: Copyright (c) Robert Greayer 2008-2010, Others 2011-2016
1515
Author: Robert Greayer <robgreayer@yahoo.com>
1616
Maintainer: "Newfie Pendragon" <elnewfie@yahoo.com>
1717
Stability: experimental
@@ -27,7 +27,7 @@ Executable LSLForge
2727
network >= 2.1 && < 2.3, random >= 1.0, containers >= 0.1 && < 0.3,
2828
old-time, utf8-string >= 0.3 && < 0.4, pureMD5 >= 0.2 && < 3,
2929
bytestring >= 0.9 && < 0.10, template-haskell >= 2.3.0.0 && < 2.4,
30-
syb >= 0.1.0.0 && < 0.2.0.0, fclabels > 0.4 && < 0.5
30+
syb >= 0.1.0.0 && < 0.2.0.0, fclabels > 0.4 && < 0.5, json == 0.7.*
3131
Main-Is: LslForge.hs
3232
Hs-Source-Dirs: src
3333
Other-modules:

‎lslforge/haskell/src/Language/Lsl/Internal/Constants.hs‎

Lines changed: 21 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -154,6 +154,17 @@ validPrimHoleType = flip elem $ map IVal [cPrimHoleDefault,cPrimHoleSquare,
154154
llcUrlRequestGranted = SVal "URL_REQUEST_GRANTED"
155155
llcUrlRequestDenied = SVal "URL_REQUEST_DENIED"
156156

157+
cJsonAppend = -1;llcJsonAppend :: RealFloat a => LSLValue a; llcJsonAppend = IVal cJsonAppend
158+
cJsonArray = "\xfdd2";llcJsonArray :: RealFloat a => LSLValue a; llcJsonArray = SVal cJsonArray
159+
cJsonDelete = "\xfdd8";llcJsonDelete :: RealFloat a => LSLValue a; llcJsonDelete = SVal cJsonDelete
160+
cJsonFalse = "\xfdd7";llcJsonFalse :: RealFloat a => LSLValue a; llcJsonFalse = SVal cJsonFalse
161+
cJsonInvalid = "\xfdd0";llcJsonInvalid :: RealFloat a => LSLValue a; llcJsonInvalid = SVal cJsonInvalid
162+
cJsonNull = "\xfdd5";llcJsonNull :: RealFloat a => LSLValue a; llcJsonNull = SVal cJsonNull
163+
cJsonNumber = "\xfdd3";llcJsonNumber :: RealFloat a => LSLValue a; llcJsonNumber = SVal cJsonNumber
164+
cJsonObject = "\xfdd1";llcJsonObject :: RealFloat a => LSLValue a; llcJsonObject = SVal cJsonObject
165+
cJsonString = "\xfdd4";llcJsonString :: RealFloat a => LSLValue a; llcJsonString = SVal cJsonString
166+
cJsonTrue = "\xfdd6";llcJsonTrue :: RealFloat a => LSLValue a; llcJsonTrue = SVal cJsonTrue
167+
157168
allConstants :: RealFloat a => [Constant a]
158169
allConstants = [
159170
Constant "ACTIVE" llcActive,
@@ -347,15 +358,16 @@ allConstants = [
347358
Constant "INVENTORY_SCRIPT" llcInventoryScript,
348359
Constant "INVENTORY_SOUND" llcInventorySound,
349360
Constant "INVENTORY_TEXTURE" llcInventoryTexture,
350-
Constant "JSON_ARRAY" (SVal "\xfdd2"),
351-
Constant "JSON_DELETE" (SVal "\xfdd8"),
352-
Constant "JSON_FALSE" (SVal "\xfdd7"),
353-
Constant "JSON_INVALID" (SVal "\xfdd0"),
354-
Constant "JSON_NULL" (SVal "\xfdd5"),
355-
Constant "JSON_NUMBER" (SVal "\xfdd3"),
356-
Constant "JSON_OBJECT" (SVal "\xfdd1"),
357-
Constant "JSON_STRING" (SVal "\xfdd4"),
358-
Constant "JSON_TRUE" (SVal "\xfdd6"),
361+
Constant "JSON_APPEND" llcJsonAppend,
362+
Constant "JSON_ARRAY" llcJsonArray,
363+
Constant "JSON_DELETE" llcJsonDelete,
364+
Constant "JSON_FALSE" llcJsonFalse,
365+
Constant "JSON_INVALID" llcJsonInvalid,
366+
Constant "JSON_NULL" llcJsonNull,
367+
Constant "JSON_NUMBER" llcJsonNumber,
368+
Constant "JSON_OBJECT" llcJsonObject,
369+
Constant "JSON_STRING" llcJsonString,
370+
Constant "JSON_TRUE" llcJsonTrue,
359371
Constant "KFM_CMD_PAUSE" (IVal 2),
360372
Constant "KFM_CMD_PLAY" (IVal 0),
361373
Constant "KFM_CMD_STOP" (IVal 1),

‎lslforge/haskell/src/Language/Lsl/Internal/InternalLLFuncs.hs‎

Lines changed: 203 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,12 @@ module Language.Lsl.Internal.InternalLLFuncs(
5353
llXorBase64Strings,
5454
llXorBase64StringsCorrect,
5555
llSHA1String,
56+
-- JSON functions
57+
llJson2List,
58+
llJsonGetValue,
59+
llJsonSetValue,
60+
llJsonValueType,
61+
llList2Json,
5662
-- Math functions
5763
llCos,
5864
llSin,
@@ -114,7 +120,8 @@ import Language.Lsl.Internal.Util(Permutation3(..),axisAngleToRotation,cut,dist3
114120
quaternionToRotations,rotationBetween,rotationsToQuaternion)
115121
import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),lslValString,parseFloat,parseInt,rot2RVal,toSVal,typeOfLSLValue,vVal2Vec)
116122
import Language.Lsl.Internal.Evaluation(EvalResult(..))
117-
import Language.Lsl.Internal.Constants(findConstVal)
123+
--import Language.Lsl.Internal.Constants(findConstVal)
124+
import Language.Lsl.Internal.Constants
118125
import Language.Lsl.Internal.Key(LSLKey(..))
119126
import Language.Lsl.Internal.SHA1(hashStoHex)
120127
import Data.List(elemIndex,find,foldl',intersperse,isPrefixOf,sort)
@@ -125,6 +132,8 @@ import qualified Data.ByteString.Lazy as L
125132
import qualified Data.Digest.Pure.MD5 as MD5
126133
import qualified Data.ByteString.UTF8 as UTF8
127134
import Network.URI(escapeURIChar,unEscapeString)
135+
import Codec.Binary.UTF8.String(encodeString,decodeString)
136+
import qualified Text.JSON as J
128137

129138
internalLLFuncNames :: [String]
130139
internalLLFuncNames = map fst (internalLLFuncs :: (Read a, RealFloat a) => [(String, a -> [LSLValue a] -> Maybe (EvalResult,LSLValue a))])
@@ -155,6 +164,11 @@ internalLLFuncs = [
155164
("llGetSubString",llGetSubString),
156165
("llInsertString",llInsertString),
157166
("llIntegerToBase64",llIntegerToBase64),
167+
("llJson2List",llJson2List),
168+
("llJsonGetValue",llJsonGetValue),
169+
("llJsonSetValue",llJsonSetValue),
170+
("llJsonValueType",llJsonValueType),
171+
("llList2Json",llList2Json),
158172
("llList2CSV",llList2CSV),
159173
("llList2Float",llList2Float),
160174
("llList2Integer",llList2Integer),
@@ -264,15 +278,90 @@ escapeURL (c:cs) n =
264278
maxResult = 254::Int
265279

266280
llEscapeURL _ [SVal string] =
267-
continueWith $ SVal $ escapeURL string maxResult
281+
continueWith $ SVal $ escapeURL (encodeString string) maxResult
268282

269283
llUnescapeURL _ [SVal string] =
270-
continueWith $ SVal $ take maxResult $ unEscapeString string
284+
continueWith $ SVal $ decodeString $ take maxResult $ unEscapeString string
271285

272286
llMD5String _ [SVal string, IVal nonce] =
273287
continueWith $ SVal $ (show . MD5.md5 . L.pack . B.unpack . UTF8.fromString) (string ++ ":" ++ show nonce)
274288

275289
llSHA1String _ [SVal string] = continueWith $ SVal (hashStoHex string)
290+
291+
-- JSON functions
292+
293+
llJson2List _ [SVal jsonstring] = continueWith $ LVal $
294+
case J.decode jsonstring of
295+
(J.Ok (J.JSArray a)) -> map js2lsl a
296+
(J.Ok (J.JSObject o)) -> concat $ map (\(k, v) -> [SVal k, js2lsl v]) $ J.fromJSObject o
297+
(J.Ok j) -> [SVal $ J.encode j]
298+
(J.Error _) -> [SVal jsonstring]
299+
300+
llJsonGetValue _ [SVal jsonstring, LVal sp] = continueWith $ SVal $
301+
case mapM convSpecifier sp of
302+
(Just sp') -> case J.decodeStrict jsonstring >>= lookupDeep' sp' of
303+
(J.Ok j) -> lslValToString $ js2lsl j
304+
otherwise -> cJsonInvalid
305+
otherwise -> cJsonInvalid
306+
307+
llJsonSetValue _ [SVal jsonstring, LVal sp, SVal val] = continueWith $ SVal $
308+
case mapM convSpecifier sp of
309+
(Just sp') -> case J.decodeStrict jsonstring >>=
310+
updateFieldDeep' sp' (decodeFromLsl val) of
311+
(J.Ok js) -> J.encode js
312+
(J.Error _) -> cJsonInvalid
313+
otherwise -> cJsonInvalid
314+
315+
llJsonValueType _ [SVal jsonstring, LVal sp] = continueWith $ SVal $
316+
case mapM convSpecifier sp of
317+
(Just sp') -> case J.decodeStrict jsonstring >>= lookupDeep' sp' of
318+
(J.Ok v) -> jsonType v
319+
otherwise -> cJsonInvalid
320+
otherwise -> cJsonInvalid
321+
where
322+
jsonType :: J.JSValue -> String
323+
jsonType J.JSNull = cJsonNull
324+
jsonType (J.JSBool b) = if b then cJsonTrue else cJsonFalse
325+
jsonType (J.JSRational _ _) = cJsonNumber
326+
jsonType (J.JSString _) = cJsonString
327+
jsonType (J.JSArray _) = cJsonArray
328+
jsonType (J.JSObject _) = cJsonObject
329+
330+
llList2Json _ [SVal typ, LVal list] = continueWith $ SVal $
331+
if typ == cJsonArray then J.encodeStrict $ J.JSArray $ map lsl2js list
332+
else if typ == cJsonObject then case l2al list of
333+
(Just al) -> J.encode (J.toJSObject al)
334+
_ -> cJsonInvalid
335+
else cJsonInvalid
336+
where
337+
lsl2js :: RealFloat a => LSLValue a -> J.JSValue
338+
lsl2js (IVal i) = J.JSRational False $ toRational i
339+
lsl2js (FVal f) = J.JSRational True $ toRational f
340+
lsl2js s = decodeFromLsl $ lslValToString s
341+
l2al :: RealFloat a => [LSLValue a] -> Maybe [(String, J.JSValue)]
342+
l2al [] = Just []
343+
l2al ((SVal k):v:xs) = l2al xs >>= \ al -> return $ (k, lsl2js v):al
344+
l2al _ = Nothing
345+
346+
convSpecifier :: RealFloat a => LSLValue a -> Maybe Specifier
347+
convSpecifier (IVal i) | i == cJsonAppend = Just Append
348+
| otherwise = Just $ Index i
349+
convSpecifier (SVal k) = Just $ Key k
350+
convSpecifier _ = Nothing
351+
352+
js2lsl :: RealFloat a => J.JSValue -> LSLValue a
353+
js2lsl (J.JSBool b) = if b then llcJsonTrue else llcJsonFalse
354+
js2lsl (J.JSRational True r) = FVal $ fromRational r
355+
js2lsl (J.JSRational False r) = IVal $ floor r
356+
js2lsl jsval = SVal $ J.encode jsval
357+
358+
decodeFromLsl :: String -> J.JSValue
359+
decodeFromLsl val | val == cJsonTrue = J.JSBool True
360+
| val == cJsonFalse = J.JSBool False
361+
| otherwise = case J.decode val of
362+
(J.Ok js) -> js
363+
_ -> J.JSString $ J.toJSString val
364+
276365
-- Math functions
277366

278367
unaryToLL :: (RealFloat a, Monad m) => (a -> a) -> [LSLValue a] -> m (EvalResult,LSLValue a)
@@ -661,3 +750,114 @@ encode1 c1 =
661750
let b1 = ((fromEnum c1) `shiftR` 2) .&. 63
662751
b2 = ((fromEnum c1) `shiftL` 4) .&. 63
663752
in [base64chars !! b1,base64chars !! b2,'=','=']
753+
754+
--
755+
-- TODO: these functions should be in separated module, like Text.JSON.Specifier
756+
--
757+
758+
data Specifier = Index Int | Append | Key String
759+
760+
-- this function shoud be called lookup in separated module
761+
jsonLookup :: Specifier -> J.JSValue -> Maybe J.JSValue
762+
jsonLookup sp json = case lookup' sp json of
763+
(J.Ok j) -> Just j
764+
(J.Error _) -> Nothing
765+
766+
findWithDefault :: J.JSValue -> Specifier -> J.JSValue -> J.JSValue
767+
findWithDefault d sp json = case lookup' sp json of
768+
(J.Ok j) -> j
769+
(J.Error _) -> d
770+
771+
lookupDeep :: [Specifier] -> J.JSValue -> Maybe J.JSValue
772+
lookupDeep sp json = case lookupDeep' sp json of
773+
(J.Ok j) -> Just j
774+
(J.Error _) -> Nothing
775+
776+
findDeepWithDefault :: J.JSValue -> [Specifier] -> J.JSValue -> J.JSValue
777+
findDeepWithDefault d sp json = case lookupDeep' sp json of
778+
(J.Ok j) -> j
779+
(J.Error _) -> d
780+
781+
updateField :: Specifier -> J.JSValue -> J.JSValue -> Maybe J.JSValue
782+
updateField sp v json = case updateField' sp v json of
783+
(J.Ok j) -> Just j
784+
(J.Error _) -> Nothing
785+
786+
updateFieldDeep :: [Specifier] -> J.JSValue -> J.JSValue -> Maybe J.JSValue
787+
updateFieldDeep sps v json = case updateFieldDeep' sps v json of
788+
(J.Ok j) -> Just j
789+
(J.Error _) -> Nothing
790+
791+
delete :: Specifier -> J.JSValue -> Maybe J.JSValue
792+
delete sp json = case delete' sp json of
793+
(J.Ok j) -> Just j
794+
otherwise -> Nothing
795+
796+
deleteDeep :: [Specifier] -> J.JSValue -> Maybe J.JSValue
797+
deleteDeep sp json = case deleteDeep' sp json of
798+
(J.Ok j) -> Just j
799+
otherwise -> Nothing
800+
801+
lookup' :: Specifier -> J.JSValue -> J.Result J.JSValue
802+
lookup' (Index i) (J.JSArray list) | i >= 0 && i < length list = return $ list !! i
803+
lookup' (Key k) (J.JSObject obj) = case lookup k $ J.fromJSObject obj of
804+
(Just j) -> return j
805+
otherwise -> J.Error "Invalid specifier"
806+
lookup' _ _ = J.Error "Invalid specifier"
807+
808+
lookupDeep' :: [Specifier] -> J.JSValue -> J.Result J.JSValue
809+
lookupDeep' [] json = return json
810+
lookupDeep' (sp:sps) json = lookup' sp json >>= lookupDeep' sps
811+
812+
updateField' :: Specifier -> J.JSValue -> J.JSValue -> J.Result J.JSValue
813+
updateField' sp v js =
814+
case js of
815+
(J.JSArray l) -> case sp of
816+
Append -> return $ J.JSArray $ l ++ [v]
817+
(Index i) -> repl l i v
818+
otherwise -> J.Error "Invalid specifier"
819+
(J.JSObject o) -> case sp of
820+
(Key k) -> return $ J.JSObject $ J.toJSObject $ addToAL (J.fromJSObject o) k v
821+
otherwise -> J.Error "Invalid parameter"
822+
otherwise -> J.Error "Invalid specifier"
823+
824+
repl :: [J.JSValue] -> Int -> J.JSValue -> J.Result J.JSValue
825+
repl [] _ _ = J.Error "Invalid specifier"
826+
repl _ i _ | i < 0 = J.Error "Invalid specifier"
827+
repl (x:xs) 0 v = return $ J.JSArray (v:xs)
828+
repl (x:xs) n v = repl xs (n - 1) v >>= \(J.JSArray t) -> return $ J.JSArray (x:t)
829+
830+
updateFieldDeep' :: [Specifier] -> J.JSValue -> J.JSValue -> J.Result J.JSValue
831+
updateFieldDeep' [] v json = return v
832+
updateFieldDeep' (Append:sps) v j@(J.JSArray _) =
833+
updateFieldDeep' sps v (J.JSArray []) >>= \t -> updateField' Append t j
834+
updateFieldDeep' (sp:sps) v json =
835+
updateFieldDeep' sps v (findWithDefault def sp json) >>= \ t -> updateField' sp t json
836+
where def = case sps of
837+
[] -> J.JSNull
838+
Append:_ -> J.JSArray []
839+
(Index _):_ -> J.JSArray []
840+
(Key _):_ -> J.JSObject $ J.toJSObject []
841+
842+
delete' :: Specifier -> J.JSValue -> J.Result J.JSValue
843+
delete' (Index i) (J.JSArray list) | i >= 0 && i < length list =
844+
return $ J.JSArray $ a ++ b where (a, (_:b)) = splitAt i list
845+
delete' (Key k) (J.JSObject obj) =
846+
return $ J.JSObject $ J.toJSObject $ delFromAL (J.fromJSObject obj) k
847+
delete' _ _ = J.Error "Invalid specifier"
848+
849+
deleteDeep' :: [Specifier] -> J.JSValue -> J.Result J.JSValue
850+
deleteDeep' [] _ = J.Error "Invalid specifier"
851+
deleteDeep' [sp] json = delete' sp json
852+
deleteDeep' (sp:sps) json =
853+
lookup' sp json >>= deleteDeep' sps >>= \ t -> updateField' sp t json
854+
855+
addToAL :: Eq k => [(k, v)] -> k -> v -> [(k, v)]
856+
addToAL [] k v = [(k, v)]
857+
addToAL (t@(x, _):xs) k v | x == k = (k, v):xs
858+
| otherwise = t:(addToAL xs k v)
859+
860+
delFromAL :: Eq k => [(k, v)] -> k -> [(k, v)]
861+
delFromAL [] k = []
862+
delFromAL (t@(x, _):xs) k | x == k = xs
863+
| otherwise = t:(delFromAL xs k)

0 commit comments

Comments
 (0)