Commit a87ee3f5 authored by Michael Hanus 's avatar Michael Hanus

Script generation made safe w.r.t. broken form info files

parent f4e5e067
......@@ -4,14 +4,15 @@
--- necessary.
---
--- @author Michael Hanus
--- @version August 2020
--- @version September 2020
------------------------------------------------------------------------------
module C2C.ExtractForms ( extractFormsInProg )
where
import Directory ( doesFileExist, getModificationTime )
import Directory ( doesFileExist, getModificationTime, removeFile )
import FilePath ( (</>), (<.>) )
import IO ( hGetContents, openFile, IOMode(..) )
import List ( intercalate, partition )
import System ( exitWith, getArgs, getPID, system )
......@@ -29,8 +30,10 @@ import C2C.TransTypedFlatCurryForms ( setFormIDsInTypedFlatCurry )
formCacheFile :: String -> String -> String
formCacheFile mdir mname = inCurrySubdir (mdir </> mname) <.> "htmlforms"
--- Extract and check all forms defined in a Curry module (third argument).
--- Returns the qualified names of the exported forms.
--- Extract and check all forms defined in a Curry module.
--- Returns the qualified names of the exported forms as the second component.
--- The first component is `Nothing` when the module was not transformed
--- to attach form ids, otherwise it is `Just` the module name.
extractFormsInProg :: Options -> String -> IO (Maybe String, [QName])
extractFormsInProg opts mname =
lookupModuleSourceInLoadPath mname >>=
......@@ -49,7 +52,14 @@ extractFormsInProg opts mname =
then readFormsInProg opts mname formfile
else do
putStrLnInter opts $ "Reading file '" ++ formfile ++ "'"
readFile formfile >>= return . read
ffcont <- openFile formfile ReadMode >>= hGetContents
case reads ffcont of
[(t,"")] -> return t
_ -> do
putStrLnInfo opts $
"WARNING: removing broken form info file '" ++ formfile ++ "'"
removeFile formfile
extractWithFormCache (mdir,mfile)
readFormsInProg :: Options -> String -> String -> IO (Maybe String, [QName])
readFormsInProg opts mname formfile = do
......@@ -62,7 +72,7 @@ readFormsInProg opts mname formfile = do
unless (null privatenames) $ putStrLn $
"WARNING: Private form operations found (and not translated):\n" ++
unwords (map snd privatenames)
unless (null formnames) $ putStrLnIfNQ opts $
unless (null formnames) $ putStrLnInfo opts $
"Form operations found: " ++ unwords (map snd formnames)
mbtrans <- if null formnames
then return Nothing
......@@ -96,7 +106,7 @@ checkFormIDsInProg opts mname formnames = do
if fidok
then return Nothing
else do
putStrLnIfNQ opts $
putStrLnInfo opts $
"Some forms have non-matching IDs: setting correct form IDs..."
case optSysName opts of
"pakcs" -> setFormIDsInFlatCurry opts mname
......
......@@ -2,7 +2,7 @@
--- Option process for the `curry2cgi` script.
---
--- @author Michael Hanus
--- @version August 2020
--- @version September 2020
------------------------------------------------------------------------------
module C2C.Options
......@@ -24,7 +24,7 @@ banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "Compile Curry programs with HTML forms to CGI executables " ++
"(Version of 18/08/20)"
"(Version of 02/09/20)"
bannerLine = take (length bannerText) (repeat '=')
------------------------------------------------------------------------------
......@@ -88,7 +88,11 @@ options =
"run quietly (no output, only exit code)"
, Option "v" ["verb"]
(OptArg (maybe (checkVerb 2) (safeReadNat checkVerb)) "<n>")
"verbosity level:\n0: quiet (same as `-q')\n1: show status messages (default)\n2: show intermediate results (same as `-v')\n3: show all details"
("verbosity level:\n" ++
"0: quiet (same as `-q')\n" ++
"1: show status messages (default)\n" ++
"2: show intermediate results (same as `-v')\n" ++
"3: show all details")
, Option "m" ["main"]
(ReqArg (\s opts -> opts { optMain = s }) "<m>")
("Curry expression (of type IO HtmlPage) computing\n" ++
......@@ -104,8 +108,9 @@ options =
"form handlers should be generated")
, Option "s" ["system"]
(ReqArg (\s opts -> opts { optSystem = s }) "<s>")
("set path to the root of Curry system\n" ++
"(then 'path/bin/curry' is invoked to compile script)")
("set path to the root of Curry system so that\n" ++
"'<s>/bin/curry' is invoked to compile script\n" ++
"(default: '" ++ installDir ++ "')")
, Option "" ["cpmexec"]
(ReqArg (\s opts -> opts { optCPM = s }) "<c>")
("set the command to execute programs with the\n" ++
......@@ -130,9 +135,6 @@ options =
then opts { optVerb = n }
else error "Illegal verbosity level (try `-h' for help)"
putStrLnIfNQ :: Options -> String -> IO ()
putStrLnIfNQ opts s = unless (optVerb opts == 0) $ putStrLn s
putStrLnInfo :: Options -> String -> IO ()
putStrLnInfo opts s = when (optVerb opts > 0) $ putStrLn s
......
......@@ -5,7 +5,7 @@
--- for executing cgi scripts.
---
--- @author Michael Hanus
--- @version August 2020
--- @version September 2020
------------------------------------------------------------------------------
module Curry2CGI ( main )
......@@ -65,7 +65,7 @@ checkCurrySystem opts = do
-- and compile it into a CGI binary.
compileCGI :: Options -> [String] -> String -> IO ()
compileCGI opts transmods mname = do
putStrLnIfNQ opts $ "Wrapping '" ++ mname ++ "' to generate CGI binary..."
putStrLnInfo opts $ "Wrapping '" ++ mname ++ "' to generate CGI binary..."
pid <- getPID
let mainmod = mname ++ "_CGIMAIN_" ++ show pid
maincall = "main_cgi_9999_" ++ show pid
......@@ -97,13 +97,13 @@ compileCGI opts transmods mname = do
cleanMain mainmod
cdate <- getLocalTime >>= return . calendarTimeToString
writeFile (cgifile ++ ".log") (cdate ++ ": cgi script compiled\n")
putStrLnIfNQ opts $
putStrLnInfo opts $
"New files \"" ++ cgifile ++ "*\" with compiled cgi script generated."
where
precompile mainmod = do
putStrLnInter opts $ "Modules transformed by setting form IDs:\n" ++
unwords transmods
putStrLnIfNQ opts $ "Pre-compiling " ++ mainmod ++ "..."
putStrLnInfo opts $ "Pre-compiling " ++ mainmod ++ "..."
case optSysName opts of
"pakcs" -> do readFlatCurry mainmod
mapM_ (copyTransFlatCurry opts) transmods
......@@ -120,7 +120,7 @@ genShellScript opts cgifile = do
system $ "/bin/rm -f " ++ cgifile
langenv <- getEnviron "LANG"
let limit = optLimit opts
let script = unlines $
script = unlines $
["#!/bin/sh"] ++
(if null langenv then []
else ["LANG=" ++ langenv, "export LANG"]) ++
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment