├── .gitignore ├── tests ├── assign_int.php ├── assign_var.php ├── call_1_arg.php ├── math_simple_add.php ├── return.php ├── assign_float.php ├── assign_null.php ├── echo_statement.php ├── if_plain.php ├── newline_ignore_after_close.php ├── unary_postfix_ops.php ├── unary_prefix_ops.php ├── assign_str_double_quote.php ├── assign_str_single_quote.php ├── call_two_with_white.php ├── plaintext_multiline_file.php ├── plaintext_space_after_php.php ├── string_double_quote_escape.php ├── string_single_quote_escape.php ├── while_simple_no_body.php ├── func_no_args_no_body.php ├── assign_bool.php ├── if_else.php ├── func_args_with_defaults.php ├── while_cond_and_body.php ├── func_no_args_simple_body.php ├── func_some_args_no_body.php └── if_elseif_else.php ├── Setup.hs ├── README.md ├── IniSettings.hs ├── VariableFunctions.hs ├── PhpInfoFunctions.hs ├── StringFunctions.hs ├── Main.hs ├── language-php.cabal ├── LICENSE ├── Runtime.hs ├── StringParse.hs ├── CodeGen.hs ├── Conversion.hs ├── runtests.hs ├── Tokenizer.hs └── Evaluator.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | -------------------------------------------------------------------------------- /tests/assign_int.php: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /tests/unary_postfix_ops.php: -------------------------------------------------------------------------------- 1 | foo 2 | -------------------------------------------------------------------------------- /tests/string_double_quote_escape.php: -------------------------------------------------------------------------------- 1 | >= newIORef 8 | where makeRef (n, v) = newIORef v >>= return . (,) n 9 | 10 | defaults = [ ("arg_separator.input", "&") 11 | , ("display_errors", "1") 12 | , ("log_errors", "0") 13 | , ("track_errors", "0") 14 | ] 15 | -------------------------------------------------------------------------------- /VariableFunctions.hs: -------------------------------------------------------------------------------- 1 | module VariableFunctions where 2 | 3 | import Tokenizer 4 | import Evaluator 5 | 6 | functions = [("var_dump", phpVarDump)] 7 | 8 | phpVarDump :: PHPFunctionType 9 | phpVarDump args = (output $ unlines $ map dump args) >> return PHPNull 10 | where dump (PHPInt i) = "int(" ++ (show i) ++ ")" 11 | dump (PHPFloat f) = "float(" ++ (show f) ++ ")" 12 | dump (PHPString s) = "string(" ++ (show $ length s) ++ ") \"" ++ s ++ "\"" 13 | dump (PHPBool b) = "bool(" ++ (show b) ++ ")" 14 | dump PHPNull = "NULL" 15 | 16 | -------------------------------------------------------------------------------- /PhpInfoFunctions.hs: -------------------------------------------------------------------------------- 1 | module PhpInfoFunctions where 2 | 3 | import Tokenizer 4 | import Conversion 5 | import Evaluator 6 | import Control.Monad.Error 7 | 8 | functions :: [(String, PHPFunctionType)] 9 | functions = [ ("ini_get", phpIniGet) 10 | , ("ini_set", phpIniSet) 11 | ] 12 | 13 | phpIniGet :: PHPFunctionType 14 | phpIniGet [] = throwError $ NotEnoughArguments "ini_get" 15 | phpIniGet (v:_) = do 16 | mIni <- lookupIniSetting $ stringFromPHPValue $ castToString v 17 | case mIni of 18 | Nothing -> return $ PHPBool False 19 | Just v -> return $ PHPString v 20 | 21 | phpIniSet :: PHPFunctionType 22 | phpIniSet (n:v:_) = do 23 | oldVal <- phpIniGet [n] 24 | setIniSetting name value 25 | return oldVal 26 | where name = stringFromPHPValue $ castToString n 27 | value = stringFromPHPValue $ castToString v 28 | 29 | phpIniSet _ = throwError $ NotEnoughArguments "ini_set" 30 | -------------------------------------------------------------------------------- /StringFunctions.hs: -------------------------------------------------------------------------------- 1 | module StringFunctions where 2 | 3 | import Tokenizer 4 | import Evaluator 5 | import Conversion 6 | import Control.Monad.Error 7 | import Data.Char 8 | 9 | functions :: [(String, PHPFunctionType)] 10 | functions = [ ("strlen", phpStrLen) 11 | , ("strtoupper", phpStrToUpper) 12 | , ("strtolower", phpStrToLower)] 13 | 14 | -- Conversion of a PHPString for a Haskell [Char] 15 | toHaskellStr :: PHPValue -> String 16 | toHaskellStr x = stringFromPHPValue $ castToString x 17 | 18 | -- Throws an arity error 19 | arityErrorFor f = throwError $ Default $ "Wrong number of arguments to " ++ f 20 | 21 | phpStrLen :: PHPFunctionType 22 | phpStrLen (s:[]) = return $ PHPInt $ toInteger $ length $ toHaskellStr s 23 | phpStrLen _ = arityErrorFor "strlen" 24 | 25 | phpStrToUpper :: PHPFunctionType 26 | phpStrToUpper (s:[]) = return $ PHPString $ map toUpper $ toHaskellStr s 27 | phpStrToUpper _ = arityErrorFor "strtoupper" 28 | 29 | phpStrToLower :: PHPFunctionType 30 | phpStrToLower (s:[]) = return $ PHPString $ map toLower $ toHaskellStr s 31 | phpStrToLower _ = arityErrorFor "strtolower" 32 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Tokenizer 4 | import Conversion 5 | import Evaluator 6 | import System.Console.GetOpt 7 | import Control.Monad 8 | import Data.IORef 9 | import System.Environment 10 | import qualified VariableFunctions 11 | import qualified PhpInfoFunctions 12 | import qualified StringFunctions 13 | import IniSettings 14 | 15 | main :: IO () 16 | main = 17 | let optDefs = [Option ['d'] [] (ReqArg id "value") "PHP.ini switch"] 18 | in do 19 | (options, args, errors) <- liftM (getOpt RequireOrder optDefs) getArgs 20 | if length args > 0 21 | then do 22 | ast <- liftM parseString $ readFile $ head args 23 | builtins <- newIORef $ VariableFunctions.functions ++ PhpInfoFunctions.functions ++ StringFunctions.functions 24 | config <- defaultConfig 25 | settings <- defaultSettings 26 | result <- runPHPEval (config { functionEnv = builtins, iniSettings = settings }) $ evalParseResults ast 27 | case result of 28 | Left err -> print err 29 | Right val -> return () 30 | else do 31 | print "Must pass file as argument" 32 | -------------------------------------------------------------------------------- /language-php.cabal: -------------------------------------------------------------------------------- 1 | -- Initial language-php.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: language-php 5 | 6 | -- PVP summary: +-+------- breaking API changes 7 | -- | | +----- non-breaking API additions 8 | -- | | | +--- code changes with no API change 9 | version: 0.0.0.1 10 | synopsis: PHP parser / evaluator 11 | 12 | -- A longer description of the package. 13 | -- description: 14 | 15 | homepage: http://jjh.fi 16 | license: BSD3 17 | license-file: LICENSE 18 | author: Jani Hartikainen 19 | maintainer: jani@jjh.fi 20 | -- copyright: 21 | category: Language 22 | build-type: Simple 23 | 24 | -- Constraint on the version of Cabal needed to build this package. 25 | cabal-version: >=1.8 26 | 27 | 28 | executable language-php 29 | -- .hs or .lhs file containing the Main module. 30 | main-is: Main.hs 31 | 32 | -- Modules included in this executable, other than Main. 33 | other-modules: Tokenizer, Conversion, Evaluator 34 | 35 | -- Other library packages from which modules are imported. 36 | build-depends: base ==4.5.*, mtl ==2.0.*, transformers ==0.2.*, parsec ==3.1.* 37 | 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Jani Hartikainen 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jani Hartikainen nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Runtime.hs: -------------------------------------------------------------------------------- 1 | module Runtime ( getString 2 | , PHPRuntime 3 | , RuntimeEnv (..) 4 | , runRuntime 5 | , output 6 | , setVar 7 | , getVar 8 | , forLoop 9 | , module Tokenizer 10 | , module Conversion 11 | ) where 12 | 13 | import Tokenizer 14 | import Conversion 15 | import Control.Monad.Trans.Class 16 | import Control.Monad.Reader 17 | import Data.IORef 18 | import Data.Maybe 19 | 20 | type PHPRuntime = ReaderT RuntimeEnv IO 21 | 22 | data RuntimeEnv = RuntimeEnv { locals :: IORef [(String, IORef PHPValue)] } 23 | 24 | runRuntime :: RuntimeEnv -> (PHPRuntime a) -> IO () 25 | runRuntime env r = void $ liftIO $ runReaderT r env 26 | 27 | getVar :: String -> PHPRuntime PHPValue 28 | getVar name = do 29 | vars <- liftM locals ask >>= liftIO . readIORef 30 | maybe (return PHPNull) (liftIO . readIORef) (lookup name vars) 31 | 32 | setVar :: String -> PHPValue -> PHPRuntime PHPValue 33 | setVar name value = do 34 | localsRef <- liftM locals ask 35 | locals <- liftIO $ readIORef localsRef 36 | case lookup name locals of 37 | Nothing -> liftIO $ do 38 | valRef <- newIORef value 39 | writeIORef localsRef ((name, valRef) : locals) 40 | return value 41 | Just ref -> liftIO $ do 42 | writeIORef ref value 43 | return value 44 | 45 | getString :: PHPValue -> String 46 | getString (PHPString s) = s 47 | getString v = getString $ castToString v 48 | 49 | output :: String -> PHPRuntime () 50 | output s = liftIO $ putStr s 51 | 52 | forLoop :: PHPRuntime () -> PHPRuntime Bool -> PHPRuntime () -> PHPRuntime () -> PHPRuntime () 53 | forLoop init cond iter expr = init >> forMain 54 | where 55 | forMain = do 56 | condTrue <- cond 57 | when condTrue expr 58 | iter 59 | when condTrue forMain 60 | -------------------------------------------------------------------------------- /StringParse.hs: -------------------------------------------------------------------------------- 1 | -- | This is an almost straight copy from Text.Parsec.Token, for the purposes of parsing 2 | -- strings that are delimited by other characters besides " 3 | 4 | module StringParse (stringLit) where 5 | 6 | import Control.Monad 7 | import Text.ParserCombinators.Parsec 8 | import Text.ParserCombinators.Parsec.Expr 9 | import Text.ParserCombinators.Parsec.Language 10 | import qualified Text.ParserCombinators.Parsec.Token as Token 11 | import Data.Char (digitToInt) 12 | 13 | stringLit lexer d = Token.lexeme lexer ( 14 | do{ str <- between (char d) 15 | (char d "end of string") 16 | (many $ stringChar d) 17 | ; return (foldr (maybe id (:)) "" str) 18 | } 19 | "literal string") 20 | 21 | stringChar d = do{ c <- stringLetter d; return (Just c) } 22 | <|> stringEscape 23 | "string character" 24 | 25 | stringLetter d = satisfy (\c -> (c /= d) && (c /= '\\') && (c > '\026')) 26 | 27 | stringEscape = do{ char '\\' 28 | ; do{ escapeGap ; return Nothing } 29 | <|> do{ escapeEmpty; return Nothing } 30 | <|> do{ esc <- escapeCode; return (Just esc) } 31 | } 32 | 33 | escapeEmpty = char '&' 34 | escapeGap = do{ many1 space 35 | ; char '\\' "end of string gap" 36 | } 37 | 38 | 39 | 40 | -- escape codes 41 | escapeCode = charEsc <|> charNum <|> charAscii <|> charControl 42 | "escape code" 43 | 44 | charControl = do{ char '^' 45 | ; code <- upper 46 | ; return (toEnum (fromEnum code - fromEnum 'A')) 47 | } 48 | 49 | charNum = do{ code <- decimal 50 | <|> do{ char 'o'; number 8 octDigit } 51 | <|> do{ char 'x'; number 16 hexDigit } 52 | ; return (toEnum (fromInteger code)) 53 | } 54 | 55 | charEsc = choice (map parseEsc escMap) 56 | where 57 | parseEsc (c,code) = do{ char c; return code } 58 | 59 | charAscii = choice (map parseAscii asciiMap) 60 | where 61 | parseAscii (asc,code) = try (do{ string asc; return code }) 62 | 63 | 64 | -- escape code tables 65 | escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") 66 | asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) 67 | 68 | ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", 69 | "FS","GS","RS","US","SP"] 70 | ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", 71 | "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", 72 | "CAN","SUB","ESC","DEL"] 73 | 74 | ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', 75 | '\EM','\FS','\GS','\RS','\US','\SP'] 76 | ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', 77 | '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', 78 | '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] 79 | 80 | 81 | decimal = number 10 digit 82 | 83 | number base baseDigit 84 | = do{ digits <- many1 baseDigit 85 | ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits 86 | ; seq n (return n) 87 | } 88 | 89 | -------------------------------------------------------------------------------- /CodeGen.hs: -------------------------------------------------------------------------------- 1 | module CodeGen where 2 | 3 | import Tokenizer 4 | import Conversion 5 | import Data.List 6 | 7 | genApp :: String -> [ParseResult] -> String 8 | genApp name parse = genModule name $ genParseResults parse 9 | 10 | genModule :: String -> String -> String 11 | genModule name body = unlines [ "module Main where" 12 | , "import Runtime" 13 | , "import Data.IORef" 14 | , "import Control.Monad" 15 | , "import Control.Applicative" 16 | , "main :: IO ()" 17 | , "main = do { ref <- newIORef [];" 18 | , " runRuntime (RuntimeEnv ref) phpMain" 19 | , " }" 20 | , "phpMain :: PHPRuntime ()" 21 | , "phpMain = do {" ++ body ++ "}" 22 | ] 23 | 24 | genParseResults :: [ParseResult] -> String 25 | genParseResults xs = unlines $ map ((++ ";") . genParseResult) xs 26 | 27 | genParseResult :: ParseResult -> String 28 | genParseResult (PlainText s) = "output " ++ show s 29 | genParseResult (PHPCode stmt) = genStmt stmt 30 | 31 | genStmt :: PHPStmt -> String 32 | genStmt (Seq xs) = unlines $ map ((++ ";") . genStmt) xs 33 | -- a literal value or lone variable statement does absolutely nothing, so remove it 34 | genStmt (Expression (Literal _)) = "" 35 | genStmt (Expression (Variable _)) = "" 36 | genStmt (Expression a@(Assign _ _)) = "(void $ " ++ (genExpr a) ++ ")" 37 | genStmt (Expression expr) = genExpr expr 38 | genStmt (For inits conds iters body) = "(forLoop " ++ initExpr ++ " " ++ condExpr ++ " " ++ iterExpr ++ " " ++ bodyExpr ++ ")" 39 | where initExpr = "(void $ do {" ++ (concatExprs ";" inits) ++ "})" 40 | condExpr = "(do { r <- sequence [" ++ (concatExprs "," conds) ++ "]; return $ all isTruthy r })" 41 | iterExpr = "(void $ do {" ++ (concatExprs ";" iters) ++ "})" 42 | bodyExpr = "(do {" ++ (genStmt body) ++ "})" 43 | concatExprs sep xs = concat $ intersperse sep $ map genExpr xs 44 | genStmt _ = "" 45 | 46 | genExpr :: PHPExpr -> String 47 | genExpr (Literal val) = "(" ++ (show val) ++ ")" 48 | genExpr (Print expr) = "((output . getString) =<< " ++ (impure genExpr expr) ++ ")" 49 | genExpr (BinaryExpr op a b) = genBinOp op a b 50 | genExpr (Assign (PHPVariable name) expr) = "(setVar " ++ (show name) ++ " =<< " ++ (impure genExpr expr) ++ ")" 51 | genExpr (Variable (PHPVariable name)) = "(getVar " ++ (show name) ++ ")" 52 | genExpr _ = "" 53 | 54 | impure :: (PHPExpr -> String) -> PHPExpr -> String 55 | impure gen a@(Literal _) = "return " ++ (gen a) 56 | impure gen expr = gen expr 57 | 58 | genBinOp :: BinOp -> PHPExpr -> PHPExpr -> String 59 | genBinOp Add a b = genBinOp' "phpSum" a b 60 | genBinOp Subtract a b = genBinOp' "phpSubtract" a b 61 | genBinOp Multiply a b = genBinOp' "phpMultiply" a b 62 | genBinOp Divide a b = genBinOp' "phpDivide" a b 63 | genBinOp Modulo a b = genBinOp' "phpModulo" a b 64 | genBinOp Equals a b = genBinOp' "boolEquals" a b 65 | genBinOp StrictEquals a b = genBinOp' "boolStrictEquals" a b 66 | genBinOp And a b = genBinOp' "boolAnd" a b 67 | genBinOp Or a b = genBinOp' "boolOr" a b 68 | genBinOp Less a b = genBinOp' "boolLess" a b 69 | genBinOp Greater a b = genBinOp' "boolGreater" a b 70 | genBinOp Concat a b = "(PHPString $ (getString $ castToString " ++ (genExpr a) ++ ") ++ (getString $ castToString " ++ (genExpr b) ++ "))" 71 | 72 | genBinOp' opFn a b = "(" ++ opFn ++ " <$> " ++ (impure genExpr a) ++ " <*> " ++ (impure genExpr b) ++ ")" 73 | -------------------------------------------------------------------------------- /Conversion.hs: -------------------------------------------------------------------------------- 1 | module Conversion where 2 | 3 | import Tokenizer 4 | import Text.Read 5 | import Data.Maybe 6 | 7 | castToBool :: PHPValue -> PHPValue 8 | castToBool (PHPString a) | a == "" = PHPBool False 9 | | a == "0" = PHPBool False 10 | | otherwise = PHPBool True 11 | 12 | castToBool (PHPInt a) | a == 0 = PHPBool False 13 | | otherwise = PHPBool True 14 | 15 | castToBool a@(PHPBool _) = a 16 | 17 | castToBool (PHPFloat a) | a == 0 = PHPBool False 18 | | otherwise = PHPBool True 19 | 20 | castToBool PHPNull = PHPBool False 21 | 22 | isTruthy :: PHPValue -> Bool 23 | isTruthy = getBool . castToBool 24 | where getBool (PHPBool b) = b 25 | 26 | castToInt :: PHPValue -> PHPValue 27 | castToInt (PHPString a) = PHPInt $ read a :: PHPValue 28 | castToInt a@(PHPInt _) = a 29 | castToInt (PHPFloat a) = PHPInt $ floor a 30 | castToInt (PHPBool a) | a == True = PHPInt 1 31 | | a == False = PHPInt 0 32 | castToInt PHPNull = PHPInt 0 33 | 34 | castToFloat :: PHPValue -> PHPValue 35 | castToFloat (PHPString a) = PHPFloat $ read a :: PHPValue 36 | castToFloat (PHPInt a) = PHPFloat $ fromInteger a 37 | castToFloat a@(PHPFloat _) = a 38 | castToFloat PHPNull = PHPFloat 0 39 | castToFloat (PHPBool a) | a == True = PHPFloat 1 40 | | a == False = PHPFloat 0 41 | 42 | castToString :: PHPValue -> PHPValue 43 | castToString a@(PHPString _) = a 44 | castToString (PHPInt a) = PHPString (show a) 45 | castToString (PHPFloat a) = PHPString (show a) 46 | castToString a@(PHPBool _) = castToString $ castToInt a 47 | castToString PHPNull = PHPString "" 48 | 49 | phpSum :: PHPValue -> PHPValue -> PHPValue 50 | phpSum (PHPFloat a) (PHPFloat b) = PHPFloat (a + b) 51 | phpSum (PHPInt a) (PHPInt b) = PHPInt (a + b) 52 | phpSum a@(PHPFloat _) b = phpSum a (castToFloat b) 53 | phpSum a b@(PHPFloat _) = phpSum (castToFloat a) b 54 | phpSum a@(PHPInt _) b = phpSum a (castToInt b) 55 | phpSum a b@(PHPInt _) = phpSum (castToInt a) b 56 | phpSum a b = phpSum (castToInt a) (castToInt b) 57 | 58 | phpSubtract :: PHPValue -> PHPValue -> PHPValue 59 | phpSubtract a b = uncurry sub $ makeCompatible (a, b) 60 | where sub (PHPFloat a) (PHPFloat b) = PHPFloat (a - b) 61 | sub (PHPInt a) (PHPInt b) = PHPInt (a - b) 62 | 63 | phpMultiply :: PHPValue -> PHPValue -> PHPValue 64 | phpMultiply a b = uncurry mul $ makeCompatible (a, b) 65 | where mul (PHPFloat a) (PHPFloat b) = PHPFloat (a * b) 66 | mul (PHPInt a) (PHPInt b) = PHPInt (a * b) 67 | 68 | phpDivide :: PHPValue -> PHPValue -> PHPValue 69 | phpDivide a b = uncurry div $ makeCompatible (a, b) 70 | where div (PHPFloat a) (PHPFloat b) | b /= 0 = PHPFloat (a / b) 71 | | otherwise = PHPBool False 72 | div (PHPInt a) (PHPInt b) | b /= 0 = let f = (fromInteger a / fromInteger b) 73 | in if (fromIntegral $ floor f) == f 74 | then PHPInt (floor f) 75 | else PHPFloat f 76 | | otherwise = PHPBool False 77 | 78 | phpModulo :: PHPValue -> PHPValue -> PHPValue 79 | phpModulo a b = uncurry m $ makeCompatible (a, b) 80 | where m (PHPInt a) (PHPInt b) | b /= 0 = PHPInt (a `mod` b) 81 | | otherwise = PHPBool False 82 | m a@(PHPFloat _) b@(PHPFloat _) = phpModulo (castToInt a) (castToInt b) 83 | 84 | makeCompatible :: (PHPValue, PHPValue) -> (PHPValue, PHPValue) 85 | makeCompatible (a@(PHPFloat _), b) = (a, castToFloat b) 86 | makeCompatible (a, b@(PHPFloat _)) = (castToFloat a, b) 87 | makeCompatible (a@(PHPInt _), b) = (a, castToInt b) 88 | makeCompatible (a, b@(PHPInt _)) = (castToInt a, b) 89 | 90 | boolAnd :: PHPValue -> PHPValue -> PHPValue 91 | boolAnd a b = PHPBool $ (isTruthy a) && (isTruthy b) 92 | 93 | boolOr :: PHPValue -> PHPValue -> PHPValue 94 | boolOr a b = PHPBool $ (isTruthy a) || (isTruthy b) 95 | 96 | boolEquals :: PHPValue -> PHPValue -> PHPValue 97 | boolEquals a b = PHPBool $ (isTruthy a) == (isTruthy b) 98 | 99 | boolStrictEquals :: PHPValue -> PHPValue -> PHPValue 100 | boolStrictEquals (PHPFloat a) (PHPFloat b) = PHPBool (a == b) 101 | boolStrictEquals (PHPInt a) (PHPInt b) = PHPBool (a == b) 102 | boolStrictEquals (PHPString a) (PHPString b) = PHPBool (a == b) 103 | boolStrictEquals (PHPBool a) (PHPBool b) = PHPBool (a == b) 104 | boolStrictEquals PHPNull PHPNull = PHPBool True 105 | boolStrictEquals _ _ = PHPBool False 106 | 107 | boolGreater :: PHPValue -> PHPValue -> PHPValue 108 | boolGreater a b = uncurry cmp $ makeCompatible (a, b) 109 | where cmp (PHPFloat a) (PHPFloat b) = PHPBool (a > b) 110 | cmp (PHPInt a) (PHPInt b) = PHPBool (a > b) 111 | 112 | boolLess :: PHPValue -> PHPValue -> PHPValue 113 | boolLess a b = uncurry cmp $ makeCompatible (a, b) 114 | where cmp (PHPFloat a) (PHPFloat b) = PHPBool (a < b) 115 | cmp (PHPInt a) (PHPInt b) = PHPBool (a < b) 116 | -------------------------------------------------------------------------------- /runtests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Framework (defaultMain, testGroup, Test) 4 | import Test.Framework.Providers.HUnit 5 | import Test.HUnit hiding (Test) 6 | 7 | import Tokenizer 8 | 9 | import Control.Monad 10 | 11 | main :: IO () 12 | main = defaultMain [testSuite] 13 | 14 | testSuite :: Test 15 | testSuite = testGroup "Parser" 16 | [ testCase "Assign int" (testFile "tests/assign_int.php" (show $ [PHPCode $ Seq [Expression (Assign (PHPVariable "foo") (Literal (PHPInt 1))) ]])) 17 | , testCase "Assign bool" (testFile "tests/assign_bool.php" ( 18 | show $ [PHPCode $ Seq [ Expression (Assign (PHPVariable "foo") (Literal (PHPBool True))) 19 | , Expression (Assign (PHPVariable "foo") (Literal (PHPBool False))) 20 | ]])) 21 | , testCase "Assign string double quote" (testFile "tests/assign_str_double_quote.php" ( 22 | show $ [PHPCode $ Seq [Expression (Assign (PHPVariable "foo") (Literal (PHPString "bar")))]])) 23 | , testCase "Assign string single quote" (testFile "tests/assign_str_single_quote.php" ( 24 | show $ [PHPCode $ Seq [Expression (Assign (PHPVariable "foo") (Literal (PHPString "bar")))]])) 25 | , testCase "Assign null" (testFile "tests/assign_null.php" (show $ [PHPCode $ Seq [Expression (Assign (PHPVariable "foo") (Literal PHPNull))]])) 26 | , testCase "Assign float" (testFile "tests/assign_float.php" (show $ [PHPCode $ Seq [Expression (Assign (PHPVariable "foo") (Literal (PHPFloat 10.5)))]])) 27 | , testCase "Assign var" (testFile "tests/assign_var.php" (show $ [PHPCode $ Seq [Expression (Assign (PHPVariable "foo") (Variable (PHPVariable "bar")))]])) 28 | , testCase "String: single quote escape" (testFile "tests/string_single_quote_escape.php" (show $ [PHPCode $ Seq [Expression (Literal $ PHPString "foo'bar")]])) 29 | , testCase "String: double quote escape" (testFile "tests/string_double_quote_escape.php" (show $ [PHPCode $ Seq [Expression (Literal $ PHPString "foo\"bar")]])) 30 | , testCase "If, plain" (testFile "tests/if_plain.php" (show $ [PHPCode $ Seq [If (Literal (PHPBool True)) (Seq []) Nothing]])) 31 | , testCase "If, else" (testFile "tests/if_else.php" (show $ [PHPCode $ Seq [If (Literal (PHPBool True)) (Seq []) (Just (Else (Seq [])))]])) 32 | , testCase "If, elseif, else" (testFile "tests/if_elseif_else.php" ( 33 | show $ [PHPCode $ Seq [If (Literal (PHPBool True)) (Seq []) 34 | (Just (ElseIf (Literal (PHPBool True)) (Seq []) 35 | (Just (Else (Seq [])))))]])) 36 | , testCase "Math: simple add" (testFile "tests/math_simple_add.php" ( 37 | show $ [PHPCode $ Seq [Expression (BinaryExpr Add (Literal (PHPInt 1)) (Literal (PHPInt 1)))]])) 38 | , testCase "Call: one arg" (testFile "tests/call_1_arg.php" ( 39 | show $ [PHPCode $ Seq [Expression (Call (FunctionCall "test") [Literal (PHPInt 1)])]])) 40 | , testCase "Call: two args with whitespace" (testFile "tests/call_two_with_white.php" ( 41 | show $ [PHPCode $ Seq [Expression (Call (FunctionCall "test") [Literal (PHPBool True),Literal (PHPInt 1)])]])) 42 | , testCase "Function: No args, no body" (testFile "tests/func_no_args_no_body.php" ( 43 | show $ [PHPCode $ Seq [Function "foo" [] (Seq [])]])) 44 | , testCase "Function: Some args, no body" (testFile "tests/func_some_args_no_body.php" ( 45 | show $ [PHPCode $ Seq [Function "foo" [ FunctionArgumentDef {argName = "test", argDefault = Nothing} 46 | , FunctionArgumentDef {argName = "test2", argDefault = Nothing}] (Seq [])]])) 47 | , testCase "Function: No args, simple body" (testFile "tests/func_no_args_simple_body.php" ( 48 | show $ [PHPCode $ Seq [Function "foo" [] (Seq [Expression (Assign (PHPVariable "hello") (Literal (PHPInt 1)))])]])) 49 | , testCase "Function: Args with defaults" (testFile "tests/func_args_with_defaults.php" ( 50 | show $ [PHPCode $ Seq [Function "x" [ FunctionArgumentDef {argName = "a", argDefault = Just (PHPInt 1)} 51 | , FunctionArgumentDef {argName = "b", argDefault = Nothing}] (Seq [])]])) 52 | , testCase "Return" (testFile "tests/return.php" (show $ [PHPCode $ Seq [Return (Literal (PHPBool True))]])) 53 | , testCase "While: simple cond no body" (testFile "tests/while_simple_no_body.php" (show $ [PHPCode $ Seq [While (Literal (PHPBool True)) (Seq [])]])) 54 | , testCase "While: cond and body" (testFile "tests/while_cond_and_body.php" ( 55 | show $ [PHPCode $ Seq [While (BinaryExpr Less (Variable (PHPVariable "i")) (Literal (PHPInt 5))) (Seq 56 | [ Expression (Assign (PHPVariable "i") (BinaryExpr Add (Variable (PHPVariable "i")) (Literal (PHPInt 1))))])]])) 57 | , testCase "Plaintext: space after PHP stmt" (testFile "tests/plaintext_space_after_php.php" (show $ [PHPCode $ Seq [Expression $ Literal $ PHPInt 1], PlainText " foo"])) 58 | , testCase "Plaintext: multiline file" (testFile "tests/plaintext_multiline_file.php" (show $ [PlainText "foo\nbar\nbaz"])) 59 | , testCase "Newline handling: ignore newline before EOF after ?>" (testFile "tests/newline_ignore_after_close.php" (show $ [PHPCode $ Seq [Expression $ Literal $ PHPInt 1]])) 60 | , testCase "Echo statement" (testFile "tests/echo_statement.php" (show $ [PHPCode $ Seq [Echo [Literal $ PHPInt 1, Literal $ PHPInt 2]]])) 61 | , testCase "Unary prefix ops" (testFile "tests/unary_prefix_ops.php" (show $ [PHPCode (Seq [Expression (UnaryExpr Before Increment (PHPVariable "bar")),Expression (UnaryExpr Before Decrement (PHPVariable "foo"))])])) 62 | , testCase "Unary postfix ops" (testFile "tests/unary_postfix_ops.php" (show $ [PHPCode (Seq [Expression (UnaryExpr After Increment (PHPVariable "bar")),Expression (UnaryExpr After Decrement (PHPVariable "foo"))])])) 63 | ] 64 | 65 | testFile :: FilePath -> String -> IO () 66 | testFile file expected = do 67 | res <- readFile file 68 | (expected @=? (show $ parseString res)) 69 | -------------------------------------------------------------------------------- /Tokenizer.hs: -------------------------------------------------------------------------------- 1 | module Tokenizer where 2 | 3 | import System.IO 4 | import Control.Monad 5 | import Text.ParserCombinators.Parsec 6 | import Text.ParserCombinators.Parsec.Expr 7 | import Text.ParserCombinators.Parsec.Language 8 | import qualified Text.ParserCombinators.Parsec.Token as Token 9 | import StringParse 10 | 11 | data PHPValue = PHPString String 12 | | PHPInt Integer 13 | | PHPFloat Double 14 | | PHPBool Bool 15 | | PHPNull 16 | deriving (Show) 17 | 18 | data PHPVariable = PHPVariable String | PHPVariableVariable String deriving (Show) 19 | data FunctionCall = FunctionCall String | FunctionCallVar PHPVariable deriving (Show) 20 | 21 | data PHPExpr = Literal PHPValue 22 | | Variable PHPVariable 23 | | Assign PHPVariable PHPExpr 24 | | Neg PHPExpr 25 | | Not PHPExpr 26 | | BinaryExpr BinOp PHPExpr PHPExpr 27 | | UnaryExpr UnaryType UnaryOp PHPVariable 28 | | Call FunctionCall [PHPExpr] 29 | | Isset [PHPVariable] 30 | | Print PHPExpr 31 | deriving (Show) 32 | 33 | data UnaryType = Before | After deriving (Show) 34 | data UnaryOp = Increment | Decrement deriving (Show) 35 | 36 | mkUnaryOp :: String -> UnaryOp 37 | mkUnaryOp "++" = Increment 38 | mkUnaryOp "--" = Decrement 39 | mkUnaryOp _ = error "Invalid unary op" 40 | 41 | data BinOp = Add | Subtract | Multiply | Divide | Modulo | And | Or | Greater | Less | Equals | StrictEquals | Concat deriving (Show) 42 | 43 | data ElseExpr = Else PHPStmt 44 | | ElseIf PHPExpr PHPStmt (Maybe ElseExpr) 45 | deriving (Show) 46 | 47 | data FunctionArgumentDef = FunctionArgumentDef { argName :: String 48 | , argDefault :: Maybe PHPValue 49 | } 50 | deriving (Show) 51 | 52 | data ParseResult = PlainText String | PHPCode PHPStmt deriving (Show) 53 | 54 | data StaticVar = StaticVar String (Maybe PHPValue) deriving (Show) 55 | 56 | data PHPStmt = Seq [PHPStmt] 57 | | Expression PHPExpr 58 | | If PHPExpr PHPStmt (Maybe ElseExpr) 59 | | Function String [FunctionArgumentDef] PHPStmt 60 | | Return PHPExpr 61 | | While PHPExpr PHPStmt 62 | | For [PHPExpr] [PHPExpr] [PHPExpr] PHPStmt 63 | | Echo [PHPExpr] 64 | | Global PHPVariable 65 | | Static [StaticVar] 66 | deriving (Show) 67 | 68 | 69 | langDef = emptyDef { Token.commentStart = "/*" 70 | , Token.commentEnd = "*/" 71 | , Token.commentLine = "//" 72 | , Token.identStart = letter 73 | , Token.identLetter = alphaNum <|> char '_' 74 | , Token.reservedNames = [ "if", "else", "elseif", "while", "break", "do", "for", "continue" 75 | , "true", "false", "null", "and", "or", "class", "function", "return" 76 | , "", "echo", "print" 77 | ] 78 | , Token.reservedOpNames = [ "=", "==", "===", "->", ".", "+", "-", "*", "/", "%", "<", ">" 79 | , "and", "or", "||", "&&", "!", "++", "--" 80 | ] 81 | } 82 | 83 | lexer = Token.makeTokenParser langDef 84 | 85 | phpString = stringLit lexer '"' <|> stringLit lexer '\'' 86 | 87 | identifier = Token.identifier lexer 88 | reserved = Token.reserved lexer 89 | float = Token.float lexer 90 | stringTok = phpString 91 | reservedOp = (Token.lexeme lexer) . string 92 | parens = Token.parens lexer 93 | braces = Token.braces lexer 94 | integer = Token.integer lexer 95 | semi = Token.semi lexer 96 | whiteSpace = Token.whiteSpace lexer 97 | 98 | whileParser :: Parser [ParseResult] 99 | whileParser = many (parsePHPCode <|> parsePlainText) 100 | 101 | phpEof = try $ do 102 | optional $ char '\n' 103 | eof 104 | 105 | parsePlainText :: Parser ParseResult 106 | parsePlainText = liftM PlainText $ do 107 | c <- anyChar 108 | har <- manyTill anyChar ((lookAhead $ reserved " phpEof) 109 | return (c : har) 110 | 111 | parsePHPCode :: Parser ParseResult 112 | parsePHPCode = do 113 | reserved "") <|> phpEof 116 | return $ PHPCode seq 117 | 118 | sequenceOfStmt = do 119 | list <- many1 oneStatement 120 | return $ Seq list 121 | 122 | statementZeroOrMore = liftM Seq $ many oneStatement 123 | 124 | statementZeroOrOne = liftM Seq $ option [] (liftM (:[]) oneStatement) 125 | 126 | -- Match a valid PHP end of statement. 127 | -- Must have ; after expression, unless closing tag 128 | -- ?> comes immediately after 129 | phpEnd = semi <|> try (string "?>") 130 | 131 | -- Parse a single PHP statement 132 | oneStatement :: Parser PHPStmt 133 | oneStatement = ifStmt 134 | <|> functionStmt 135 | <|> returnStmt 136 | <|> whileStmt 137 | <|> forStmt 138 | <|> echoStmt 139 | <|> globalStmt 140 | <|> staticStmt 141 | <|> stmtExpr 142 | -- Special case for an expression that's a statement 143 | -- Expressions can be used without a semicolon in the end in ifs or whatever, 144 | -- but a valid statement expression needs a semi in the end 145 | where stmtExpr = do 146 | expr <- phpExpression 147 | phpEnd 148 | return $ Expression expr 149 | 150 | staticStmt :: Parser PHPStmt 151 | staticStmt = do 152 | stmt <- reserved "static" >> (liftM Static $ sepBy staticArg (Token.symbol lexer ",")) 153 | semi 154 | return stmt 155 | where staticArg = do 156 | char '$' 157 | name <- identifier 158 | defValue <- optionMaybe $ do 159 | Token.symbol lexer "=" 160 | phpValue 161 | 162 | return $ StaticVar name defValue 163 | 164 | globalStmt :: Parser PHPStmt 165 | globalStmt = do 166 | global <- reserved "global" >> liftM Global plainVariableExpr 167 | semi 168 | return global 169 | 170 | echoStmt :: Parser PHPStmt 171 | echoStmt = do 172 | reserved "echo" 173 | -- echo take one arg only if parens are used, otherwise 1 or more 174 | args <- (liftM (:[]) $ parens phpExpression) <|> argList 175 | phpEnd 176 | return $ Echo args 177 | where argList = sepBy phpExpression (Token.symbol lexer ",") 178 | 179 | returnStmt :: Parser PHPStmt 180 | returnStmt = do 181 | reserved "return" 182 | ret <- liftM Return phpExpression 183 | phpEnd 184 | return $ ret 185 | 186 | functionStmt :: Parser PHPStmt 187 | functionStmt = do 188 | reserved "function" 189 | name <- identifier 190 | argDefs <- parens $ sepBy argDefExpr (optional (Token.symbol lexer ",")) 191 | body <- braces statementZeroOrMore 192 | return $ Function name argDefs body 193 | where 194 | argDefExpr = do 195 | char '$' 196 | name <- identifier 197 | defValue <- optionMaybe $ do 198 | Token.symbol lexer "=" 199 | phpValue 200 | 201 | return $ FunctionArgumentDef name defValue 202 | 203 | whileStmt :: Parser PHPStmt 204 | whileStmt = do 205 | reserved "while" 206 | cond <- parens phpExpression 207 | stmt <- (braces statementZeroOrMore) <|> oneStatement 208 | return $ While cond stmt 209 | 210 | forStmt :: Parser PHPStmt 211 | forStmt = do 212 | reserved "for" 213 | (init, cond, iter) <- parens $ do 214 | minit <- sepBy phpExpression (Token.symbol lexer ",") 215 | semi 216 | mcond <- sepBy phpExpression (Token.symbol lexer ",") 217 | semi 218 | miter <- sepBy phpExpression (Token.symbol lexer ",") 219 | return (minit, mcond, miter) 220 | body <- (braces statementZeroOrMore) <|> do { s <- statementZeroOrOne; semi; return s } 221 | return $ For init cond iter body 222 | 223 | ifStmt :: Parser PHPStmt 224 | ifStmt = do 225 | reserved "if" 226 | cond <- parens phpExpression 227 | stmt1 <- (braces statementZeroOrMore) <|> oneStatement 228 | cont <- optionMaybe (elseIfStmt <|> elseStmt) 229 | return $ If cond stmt1 cont 230 | 231 | elseStmt :: Parser ElseExpr 232 | elseStmt = do 233 | reserved "else" 234 | stmt <- (braces statementZeroOrMore) <|> oneStatement 235 | return $ Else stmt 236 | 237 | elseIfStmt :: Parser ElseExpr 238 | elseIfStmt = do 239 | reserved "elseif" 240 | cond <- parens phpExpression 241 | stmt <- (braces statementZeroOrMore) <|> oneStatement 242 | cont <- optionMaybe (elseIfStmt <|> elseStmt) 243 | return $ ElseIf cond stmt cont 244 | 245 | assignExpr :: Parser PHPExpr 246 | assignExpr = do 247 | var <- plainVariableExpr 248 | reservedOp "=" 249 | expr <- phpExpression 250 | return $ Assign var expr 251 | 252 | plainVariableExpr :: Parser PHPVariable 253 | plainVariableExpr = try varVarExpr <|> normalVariableExpr 254 | where 255 | varVarExpr = char '$' >> char '$' >> fmap PHPVariableVariable identifier 256 | 257 | normalVariableExpr :: Parser PHPVariable 258 | normalVariableExpr = char '$' >> fmap PHPVariable identifier 259 | 260 | phpExpression :: Parser PHPExpr 261 | phpExpression = buildExpressionParser phpOperators phpTerm 262 | 263 | phpOperators = [ [Infix (reservedOp "*" >> return (BinaryExpr Multiply)) AssocLeft] 264 | , [Infix (reservedOp "/" >> return (BinaryExpr Divide)) AssocLeft] 265 | , [Infix (reservedOp "+" >> return (BinaryExpr Add)) AssocLeft] 266 | , [Infix (reservedOp "-" >> return (BinaryExpr Subtract)) AssocLeft] 267 | , [Infix (reservedOp "." >> return (BinaryExpr Concat)) AssocLeft] 268 | , [Infix (reservedOp "==" >> return (BinaryExpr Equals)) AssocLeft] 269 | , [Infix (reservedOp "===" >> return (BinaryExpr StrictEquals)) AssocLeft] 270 | , [Prefix (reservedOp "!" >> return (Not))] 271 | , [Infix (reservedOp "&&" >> return (BinaryExpr And)) AssocLeft] 272 | , [Infix (reservedOp "||" >> return (BinaryExpr Or)) AssocLeft] 273 | , [Infix (reservedOp "<" >> return (BinaryExpr Less)) AssocLeft] 274 | , [Infix (reservedOp ">" >> return (BinaryExpr Greater)) AssocLeft] 275 | ] 276 | 277 | phpTerm = parens phpExpression 278 | <|> try issetExpr 279 | <|> try printExpr 280 | <|> try functionCallExpr 281 | <|> try assignExpr 282 | <|> variableExpr 283 | <|> liftM Literal phpValue 284 | 285 | issetExpr :: Parser PHPExpr 286 | issetExpr = do 287 | reserved "isset" 288 | vars <- parens $ sepBy1 plainVariableExpr (Token.symbol lexer ",") 289 | return $ Isset vars 290 | 291 | variableExpr :: Parser PHPExpr 292 | variableExpr = do 293 | prefixOp <- unaryOp 294 | var <- plainVariableExpr 295 | case prefixOp of 296 | Just op -> return $ UnaryExpr Before (mkUnaryOp op) var 297 | Nothing -> do 298 | postOp <- unaryOp 299 | case postOp of 300 | Nothing -> return $ Variable var 301 | Just op -> return $ UnaryExpr After (mkUnaryOp op) var 302 | where 303 | unaryOp = optionMaybe (try (reservedOp "++") <|> try (reservedOp "--")) 304 | 305 | functionCallExpr :: Parser PHPExpr 306 | functionCallExpr = try varCall <|> nameCall 307 | where 308 | varCall = do 309 | var <- plainVariableExpr 310 | args <- parens argList 311 | return $ Call (FunctionCallVar var) args 312 | nameCall = do 313 | name <- identifier 314 | args <- parens argList 315 | return $ Call (FunctionCall name) args 316 | argList = sepBy phpExpression (Token.symbol lexer ",") 317 | 318 | printExpr :: Parser PHPExpr 319 | printExpr = do 320 | reserved "print" 321 | arg <- parens phpExpression <|> phpExpression 322 | return $ Print arg 323 | 324 | phpValue :: Parser PHPValue 325 | phpValue = (reserved "true" >> return (PHPBool True)) 326 | <|> (reserved "false" >> return (PHPBool False)) 327 | <|> (reserved "null" >> return PHPNull) 328 | <|> (Token.naturalOrFloat lexer >>= return . either PHPInt PHPFloat) 329 | <|> (stringTok >>= return . PHPString) 330 | 331 | parseString :: String -> [ParseResult] 332 | parseString str = case parse whileParser "" str of 333 | Left e -> error $ show e 334 | Right r -> case last r of 335 | PlainText "\n" -> init r 336 | _ -> r 337 | -------------------------------------------------------------------------------- /Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Evaluator where 2 | 3 | import Tokenizer 4 | import Conversion 5 | import Data.IORef 6 | import Data.Maybe 7 | import Data.List 8 | import Control.Monad.Error 9 | import Control.Monad.Reader 10 | import Control.Monad.Trans.Class 11 | import qualified Data.Traversable as Traversable 12 | import Debug.Trace 13 | 14 | data PHPError = UndefinedVariable String 15 | | NotEnoughArguments String 16 | | NotFound String String 17 | | Default String 18 | 19 | showPHPError :: PHPError -> String 20 | showPHPError (UndefinedVariable s) = "undefined variable: " ++ s 21 | showPHPError (NotEnoughArguments s) = "Function '" ++ s ++ "' was not passed enough arguments" 22 | showPHPError (NotFound msg name) = msg ++ ": " ++ name 23 | showPHPError (Default s) = "error: " ++ s 24 | 25 | instance Show PHPError where 26 | show = showPHPError 27 | 28 | instance Error PHPError where 29 | noMsg = Default "Error" 30 | strMsg = Default 31 | 32 | type PHPFunctionType = [PHPValue] -> PHPEval PHPValue 33 | 34 | type VariableList = [(String, IORef PHPValue)] 35 | type VariableEnv = IORef VariableList 36 | 37 | type FunctionList = [(String, PHPFunctionType)] 38 | type FunctionEnv = IORef FunctionList 39 | 40 | type IniSetting = (String, IORef String) 41 | type IniSettings = IORef [IniSetting] 42 | 43 | type FunctionStatics = [(String, IORef PHPValue)] 44 | type FunctionStaticEnv = IORef [(String, IORef FunctionStatics)] 45 | 46 | data EvalConfig = EvalConfig { variableEnv :: VariableEnv 47 | , functionEnv :: FunctionEnv 48 | , globalRef :: Maybe VariableEnv 49 | , outputHandler :: String -> IO () 50 | , iniSettings :: IniSettings 51 | , functionStaticEnv :: FunctionStaticEnv 52 | , currentFunction :: Maybe String 53 | } 54 | 55 | type ErrMonad = ErrorT PHPError IO 56 | 57 | type PHPEval = ReaderT EvalConfig ErrMonad 58 | 59 | emptyEnv :: IO (IORef [a]) 60 | emptyEnv = newIORef [] 61 | 62 | defaultConfig :: IO EvalConfig 63 | defaultConfig = do 64 | v <- emptyEnv 65 | f <- emptyEnv 66 | i <- emptyEnv 67 | s <- emptyEnv 68 | return $ EvalConfig v f Nothing putStr i s Nothing 69 | 70 | output :: String -> PHPEval () 71 | output s = do 72 | fn <- liftM outputHandler ask 73 | liftIO $ fn s 74 | 75 | getRef :: (EvalConfig -> IORef a) -> PHPEval (IORef a) 76 | getRef accessor = liftM accessor ask 77 | 78 | readRef :: (EvalConfig -> IORef a) -> PHPEval a 79 | readRef accessor = getRef accessor >>= liftIO . readIORef 80 | 81 | pushRef :: IORef [a] -> a -> PHPEval () 82 | pushRef ref val = liftIO $ do 83 | list <- readIORef ref 84 | writeIORef ref (val : list) 85 | 86 | getCurrentFunction :: PHPEval (Maybe String) 87 | getCurrentFunction = liftM currentFunction ask 88 | 89 | getFunctionStatics :: String -> PHPEval FunctionStatics 90 | getFunctionStatics fn = do 91 | statics <- readRef functionStaticEnv 92 | case lookup fn statics of 93 | Nothing -> return [] 94 | Just ref -> liftIO $ readIORef ref 95 | 96 | putFunctionStatics :: String -> StaticVar -> PHPEval (IORef PHPValue) 97 | putFunctionStatics func (StaticVar name mval) = do 98 | mref <- readRef functionStaticEnv >>= return . (lookup name) 99 | valref <- liftIO $ newIORef $ fromMaybe PHPNull mval 100 | case mref of 101 | Just fref -> do 102 | statics <- liftIO $ readIORef fref 103 | case lookup name statics of 104 | Nothing -> do 105 | pushRef fref (name, valref) 106 | return valref 107 | Just _ -> return valref 108 | Nothing -> do 109 | statics <- liftIO $ newIORef [(name, valref)] 110 | fse <- getRef functionStaticEnv 111 | pushRef fse (func, statics) 112 | return valref 113 | 114 | lookupIniSetting :: String -> PHPEval (Maybe String) 115 | lookupIniSetting v = do 116 | settings <- readRef iniSettings 117 | r <- liftIO $ Traversable.sequence $ fmap readIORef $ lookup v settings 118 | return r 119 | 120 | setIniSetting :: String -> String -> PHPEval () 121 | setIniSetting s v = do 122 | allRef <- getRef iniSettings 123 | settings <- liftIO $ readIORef allRef 124 | 125 | case lookup s settings of 126 | Nothing -> liftIO $ do 127 | newRef <- newIORef v 128 | writeIORef allRef ((s, newRef) : settings) 129 | Just oldRef -> do 130 | liftIO $ writeIORef oldRef v 131 | 132 | -- returns reference to local var environment 133 | -- could be global, if variable is at root level execution 134 | varEnvRef :: PHPEval VariableEnv 135 | varEnvRef = liftM variableEnv ask 136 | 137 | -- returns reference to global var env even if inside a function 138 | globalVarsRef :: PHPEval VariableEnv 139 | globalVarsRef = do 140 | mref <- liftM globalRef ask 141 | case mref of 142 | Nothing -> varEnvRef 143 | Just ref -> return ref 144 | 145 | isInFunctionContext :: PHPEval Bool 146 | isInFunctionContext = liftM globalRef ask >>= return . isJust 147 | 148 | globalFunctionsRef :: PHPEval FunctionEnv 149 | globalFunctionsRef = liftM functionEnv ask 150 | 151 | varDefs :: PHPEval VariableList 152 | varDefs = varEnvRef >>= liftIO . readIORef 153 | 154 | isDefined :: String -> PHPEval Bool 155 | isDefined var = varDefs >>= return . isJust . lookup var 156 | 157 | getVar :: String -> PHPEval PHPValue 158 | getVar var = do 159 | e <- varDefs 160 | maybe (throwError $ UndefinedVariable var) 161 | (liftIO . readIORef) 162 | (lookup var e) 163 | 164 | setVar :: String -> PHPValue -> PHPEval PHPValue 165 | setVar var val = do 166 | ref <- varEnvRef 167 | e <- liftIO $ readIORef ref 168 | defined <- isDefined var 169 | if defined 170 | then liftIO $ do 171 | writeIORef (fromJust $ lookup var e) val 172 | return val 173 | else liftIO $ do 174 | valueRef <- newIORef val 175 | writeIORef ref ((var, valueRef) : e) 176 | return val 177 | 178 | setVarRef :: String -> IORef PHPValue -> PHPEval () 179 | setVarRef var valref = do 180 | ref <- varEnvRef 181 | e <- liftIO $ readIORef ref 182 | defined <- isDefined var 183 | if defined 184 | then liftIO $ do 185 | writeIORef ref $ (var, valref) : fromMaybe e (find ((== var) . fst) e >>= return . (flip delete) e) 186 | return () 187 | else liftIO $ do 188 | writeIORef ref ((var, valref) : e) 189 | return () 190 | 191 | lookupFunction :: String -> PHPEval (Maybe PHPFunctionType) 192 | lookupFunction name = do 193 | gref <- globalFunctionsRef 194 | globalFuncs <- liftIO $ readIORef gref 195 | return $ lookup name globalFuncs 196 | 197 | defineFunction :: String -> [FunctionArgumentDef] -> PHPStmt -> PHPEval () 198 | defineFunction name args body = do 199 | gref <- globalFunctionsRef 200 | globalFuncs <- liftIO $ readIORef gref 201 | case lookup name globalFuncs of 202 | Just _ -> throwError $ Default ("Cannot redeclare function " ++ name) 203 | Nothing -> liftIO $ do 204 | writeIORef gref ((name, makeFunction name args body) : globalFuncs) 205 | return () 206 | 207 | makeFunction :: String -> [FunctionArgumentDef] -> PHPStmt -> PHPFunctionType 208 | makeFunction name argDefs body = 209 | let requiredArgsCount = length $ dropWhile (isJust . argDefault) $ reverse argDefs 210 | requiredArgsCheck args = when (length args < requiredArgsCount) (throwError $ Default $ "Not enough arguments to function " ++ name) 211 | applyArgs args = mapM (uncurry setVarOrDef) $ zip argDefs $ concat [map Just args, repeat mzero] 212 | setVarOrDef def val = case val of 213 | Just v -> setVar (argName def) v 214 | Nothing -> setVar (argName def) (fromJust $ argDefault def) 215 | in (\args -> do 216 | requiredArgsCheck args 217 | applyArgs args 218 | result <- evalStmt body 219 | case result of 220 | Nothing -> return PHPNull 221 | Just v -> return v 222 | ) 223 | 224 | evalExpr :: PHPExpr -> PHPEval PHPExpr 225 | evalExpr (BinaryExpr op a b) = do 226 | av <- liftM exprVal (evalExpr a) 227 | bv <- liftM exprVal (evalExpr b) 228 | return $ Literal $ case op of 229 | Add -> phpSum av bv 230 | Subtract -> phpSubtract av bv 231 | Multiply -> phpMultiply av bv 232 | Divide -> case phpDivide av bv of 233 | PHPBool _ -> error "Division by zero" 234 | v -> v 235 | Modulo -> phpModulo av bv 236 | And -> boolAnd av bv 237 | Or -> boolOr av bv 238 | Greater -> boolGreater av bv 239 | Less -> boolLess av bv 240 | Equals -> boolEquals av bv 241 | StrictEquals -> boolStrictEquals av bv 242 | Concat -> PHPString $ (stringFromPHPValue $ castToString av) ++ (stringFromPHPValue $ castToString bv) 243 | 244 | evalExpr a@(Literal _) = return a 245 | evalExpr (Assign (PHPVariable varName) expr) = do 246 | v <- liftM exprVal (evalExpr expr) 247 | setVar varName v 248 | return $ Literal v 249 | 250 | evalExpr (Assign (PHPVariableVariable vn) expr) = do 251 | var <- getVar vn 252 | evalExpr $ Assign (PHPVariable $ stringFromPHPValue var) expr 253 | 254 | evalExpr (Variable (PHPVariable var)) = do 255 | val <- getVar var 256 | return $ Literal val 257 | 258 | evalExpr (Variable (PHPVariableVariable vn)) = do 259 | var <- liftM stringFromPHPValue (getVar vn) 260 | evalExpr $ Variable (PHPVariable var) 261 | 262 | evalExpr (Call (FunctionCall n) args) = do 263 | mfn <- lookupFunction n 264 | case mfn of 265 | Nothing -> throwError $ NotFound "Function not found" n 266 | Just fn -> do 267 | locals <- liftIO $ emptyEnv 268 | getFunctionStatics n >>= mapM_ (pushRef locals) 269 | globalRef <- globalVarsRef 270 | args' <- mapM evalExpr args 271 | let vals = map exprVal args' 272 | local (localEnv locals globalRef) $ liftM Literal $ fn vals 273 | where 274 | localEnv locals globals env = env { variableEnv = locals, globalRef = Just globals, currentFunction = Just n } 275 | 276 | evalExpr (UnaryExpr utype uop var) = case utype of 277 | Before -> runOp uop var >> evalExpr (Variable var) 278 | After -> do 279 | val <- liftM exprVal $ evalExpr (Variable var) 280 | runOp uop var 281 | return $ Literal val 282 | where 283 | runOp op var = do 284 | vn <- varName var 285 | getVar vn >>= runOp' op >>= setVar vn 286 | runOp' _ b@(PHPBool _) = return b 287 | runOp' Increment PHPNull = return $ PHPInt 1 288 | runOp' Decrement PHPNull = return PHPNull 289 | runOp' _ (PHPString _) = error "undefined behavior for string unary op" 290 | runOp' op (PHPFloat f) = return $ PHPFloat (numOp op f) 291 | runOp' op (PHPInt i) = return $ PHPInt (numOp op i) 292 | numOp op num = case op of 293 | Increment -> num + 1 294 | Decrement -> num - 1 295 | 296 | evalExpr (Isset vars) = liftM Literal $ isset vars 297 | where isset [] = return $ PHPBool True 298 | isset ((PHPVariable x):xs) = do 299 | defs <- varDefs 300 | case lookup x defs of 301 | Nothing -> return $ PHPBool False 302 | Just ref -> do 303 | val <- liftIO $ readIORef ref 304 | case val of 305 | PHPNull -> return $ PHPBool False 306 | _ -> isset xs 307 | 308 | evalExpr (Print expr) = evalExpr expr >>= phpEcho . (:[]) . exprVal >> (return $ Literal $ PHPInt 1) 309 | 310 | varName :: PHPVariable -> PHPEval String 311 | varName (PHPVariable n) = return n 312 | varName (PHPVariableVariable vv) = liftM stringFromPHPValue $ getVar vv 313 | 314 | 315 | exprVal :: PHPExpr -> PHPValue 316 | exprVal (Literal v) = v 317 | exprVal _ = error "Value that are not literals must be evaluated first" 318 | 319 | stmtVal :: PHPStmt -> PHPValue 320 | stmtVal (Expression e) = exprVal e 321 | stmtVal _ = error "Only expressions can be evaluated into values" 322 | 323 | stringFromPHPValue :: PHPValue -> String 324 | stringFromPHPValue (PHPString s) = s 325 | stringFromPHPValue _ = error "Non-PHPString values shouldn't be attempted to be converted to plain strings" 326 | 327 | evalStmt :: PHPStmt -> PHPEval (Maybe PHPValue) 328 | evalStmt (Seq xs) = foldSeq xs 329 | where foldSeq (x:xs) = do 330 | result <- evalStmt x 331 | case result of 332 | Nothing -> foldSeq xs 333 | Just v -> return $ Just v 334 | foldSeq [] = return Nothing 335 | 336 | evalStmt (Expression expr) = evalExpr expr >> return Nothing 337 | evalStmt (Function name argDefs body) = defineFunction name argDefs body >> return Nothing 338 | evalStmt (Return expr) = liftM (Just . exprVal) (evalExpr expr) 339 | evalStmt (Echo exs) = mapM evalExpr exs >>= phpEcho . map exprVal >> return Nothing 340 | evalStmt (Static vars) = mapM makeStatic vars >> return Nothing 341 | where makeStatic var@(StaticVar name mval) = do 342 | mfunc <- getCurrentFunction 343 | case mfunc of 344 | Nothing -> return () 345 | Just func -> do 346 | statics <- getFunctionStatics func 347 | case lookup name statics of 348 | Nothing -> do 349 | putFunctionStatics func var >>= setVarRef name 350 | return () 351 | _ -> return () 352 | 353 | evalStmt (Global var) = do 354 | hasCtx <- isInFunctionContext 355 | if hasCtx == False 356 | then return Nothing 357 | else do 358 | name <- varName var 359 | globals <- globalVarsRef >>= liftIO . readIORef 360 | locals <- varDefs 361 | localRef <- varEnvRef 362 | maybe (return Nothing) 363 | (\ref -> do 364 | liftIO $ writeIORef localRef $ (name, ref) : fromMaybe locals (find ((== name) . fst) locals >>= return . (flip delete) locals) 365 | return Nothing) 366 | (lookup name globals) 367 | 368 | 369 | evalStmt (If condExpr body mElse) = do 370 | condResult <- liftM exprVal $ evalExpr condExpr 371 | if isTruthy condResult 372 | then evalStmt body 373 | else maybe (return Nothing) evalElseExpr mElse 374 | 375 | evalStmt w@(While cond body) = do 376 | condResult <- liftM exprVal $ evalExpr cond 377 | if isTruthy condResult 378 | then do 379 | evalStmt body 380 | evalStmt w 381 | else return Nothing 382 | 383 | evalStmt (For init cond iter body) = do 384 | mapM_ evalExpr init 385 | forMain cond iter body 386 | return Nothing 387 | where 388 | forMain cond iter body = do 389 | condTrue <- mapM evalExpr cond >>= return . all (isTruthy . exprVal) 390 | when (condTrue || length cond == 0) $ void $ evalStmt body 391 | mapM_ evalExpr iter 392 | when (condTrue || length cond == 0) $ forMain cond iter body 393 | 394 | evalElseExpr :: ElseExpr -> PHPEval (Maybe PHPValue) 395 | evalElseExpr (Else stmt) = evalStmt stmt 396 | evalElseExpr (ElseIf condExpr body mElse) = evalStmt $ If condExpr body mElse 397 | 398 | evalParseResult :: ParseResult -> PHPEval String 399 | evalParseResult (PlainText t) = output t >> return t 400 | evalParseResult (PHPCode stmt) = do 401 | res <- evalStmt stmt 402 | case res of 403 | Nothing -> return "" 404 | Just v -> return $ stringFromPHPValue $ castToString v 405 | 406 | evalParseResults :: [ParseResult] -> PHPEval String 407 | evalParseResults rs = liftM concat $ mapM evalParseResult rs 408 | 409 | runPHPEval :: EvalConfig -> (PHPEval a) -> IO (Either PHPError a) 410 | runPHPEval config eval = runErrorT $ runReaderT eval config 411 | 412 | phpEcho :: PHPFunctionType 413 | phpEcho xs = mapM (output . stringFromPHPValue . castToString) xs >> return PHPNull 414 | --------------------------------------------------------------------------------