diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,12 @@ +Plsl_tools +Copyright (c) 2008, Larry Layland +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of the plsl_tools nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE + diff --git a/PlslTools.cabal b/PlslTools.cabal new file mode 100644 --- /dev/null +++ b/PlslTools.cabal @@ -0,0 +1,28 @@ +Name: PlslTools +Version: 0.0.2 +Cabal-Version: >= 1.2 +License: BSD3 +License-File: LICENSE +Author: Larry Layland +Homepage: LLayland.wordpress.com +Category: PL/SQL tools +Synopsis: So far just a lint like program for PL/SQL. Diff and refactoring tools are planned +Stability: alpha +Build-Type: Simple +Data-Files: changelog.txt, plsl_lint/test_files/test_pl.sql + +Executable PlslLint + Build-Depends: old-locale >= 1.0.0.0, + old-time >= 1.0.0.0, + filepath >= 1.1.0.0, + directory >= 1.0.0.1, + process >= 1.0.0.1, + random >= 1.0.0.0, + array >= 0.1.0.0, + haskell98, base, + parsec >= 2.1.0.1 + Main-Is: Main.hs + Hs-Source-Dirs: plsl_lint + Other-Modules: Plsl_ast, Plsl_parse + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/changelog.txt b/changelog.txt new file mode 100644 --- /dev/null +++ b/changelog.txt @@ -0,0 +1,3 @@ +fixed whitespace around operators bug + +fixed bug where the "where" clause for a delete statement was always emptyö diff --git a/plsl_lint/Main.hs b/plsl_lint/Main.hs new file mode 100644 --- /dev/null +++ b/plsl_lint/Main.hs @@ -0,0 +1,25 @@ +module Main where + +{- +Copyright (c) 2008, Larry Layland +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of the plsl_lint nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +import System +import Plsl_parse( prettyWhileFromFile ) + +main = do{ args <- getArgs + ; case (length args) of + 0 -> prettyWhileFromFile "test_pl.sql" "c:\\temp\\pl_lint_out.html" + 1 -> prettyWhileFromFile (args!!0) "c:\\temp\\pl_lint_out.html" + 2 -> prettyWhileFromFile (args!!0) (args!!1) + } + diff --git a/plsl_lint/Plsl_ast.hs b/plsl_lint/Plsl_ast.hs new file mode 100644 --- /dev/null +++ b/plsl_lint/Plsl_ast.hs @@ -0,0 +1,510 @@ +module Plsl_ast where + +{- +Copyright (c) 2008, Larry Layland +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of the plsl_lint nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + + + +import Data.List +import Data.Char +import Maybe + +data Program + = ProgramStat Stat + | ProgramDec Dec + deriving (Eq) + +instance Show Program where + show (ProgramStat s) = show s + show (ProgramDec d) = show d + +type BlockName = Label + +type Context = String + +type BulkIntoClause = BasicSqlClause +type IntoClause = BasicSqlClause +type WhereClause = BasicSqlClause +type GroupByClause = BasicSqlClause +type HavingClause = WhereClause +type OrderByClause = BasicSqlClause +type ReturnClause = BasicSqlClause +type SetClause = BasicSqlClause +type InsertColClause = BasicSqlClause +type InsertValClause = BasicSqlClause + +type Distinct = String + +type CurrentOf = (Maybe Ident) + +data BasicSqlClause + = BasicSqlClause (Maybe [SqlExp]) + deriving (Eq) + + +data FromClause + = FromClause [SqlExp] + deriving (Eq, Show) + + +data WithClause + = WithClause [(Ident, SqlExp)] + deriving (Eq) + +data SetOp + = SetOp String Select OrderByClause + deriving (Eq, Show) + + +data Select + = Select Distinct [SqlExp] + BulkIntoClause IntoClause FromClause WhereClause GroupByClause HavingClause OrderByClause ReturnClause WithClause + [SetOp] + deriving (Eq) + + + + +data FormalParam + = FormalParam Ident String String PlType Nullable AExp + deriving (Eq) + +type Constant = Bool +type Nullable = Bool +type ReturnType = (Maybe Ident) + +data Dec + = VarDec Ident String PlType Constant Nullable AExp + | ProcedureSpecDec Label (Seq FormalParam) ReturnType String + | DecWithBody Dec BlockStat + | DecWithSelect Dec Select + | Pragma Ident [Char] + | RecordDec Ident (Seq Dec) + | TableDec Ident PlType (Maybe PlType) Nullable + | VarrayDec Ident PlType AExp Nullable + deriving (Eq) + + +data Ident + = NIdent String Context + | QIdent String Context + | QualIdent [Ident] Context + +instance Eq Ident where + (==) (NIdent a _) (NIdent b _) = (map toUpper a) == (map toUpper b) + (==) (QIdent a _) (QIdent b _) = a==b + (==) (QualIdent a _) (QualIdent b _) = a==b + (==) _ _ = False + +data AExp + = Var Ident + | IntLit Integer + | StringLit String + | AOp String AExp AExp + | AUnOp String AExp + | NullLiteral + | DummyAExp Context + | BUnOp String AExp + | BoolLit Bool + | NullBoolLit + | BOp String AExp AExp + | RelOp String AExp AExp + | RelUnOp String AExp + | AExpList String [AExp] + | FunctionCall ProcCall + | NestedSelect Select + | BetweenExpr AExp AExp AExp + deriving (Eq) + +data ProcCall + = ProcCall Ident (Seq ActualParam) + deriving (Eq) + +data Analytic + = Analytic BasicSqlClause BasicSqlClause + +data ActualParam + = UnNamedParam AExp + | NamedParam Ident AExp + deriving (Eq) + +data SqlExp + = UnNamedSqlExp AExp + | NamedSqlExp Ident AExp + deriving (Eq) + + +data If' = If' AExp (Seq Stat) + deriving (Eq) + +data CaseOf' = CaseOf' (Maybe AExp) (Seq Stat) + deriving (Eq) + +data Handler = Handler [Ident] (Seq Stat) + deriving (Eq) + + +data Stat +-- = Assign Ident AExp + = Assign AExp AExp + | Exit AExp Label + | Goto Label + | ReturnStat + | ReturnValueStat AExp + | BlockWrap BlockName BlockStat + | NullStat + | RaiseStat (Maybe Ident) + | CommitStat (Maybe AExp) [String] (Maybe AExp) (Maybe AExp) + | RollbackStat (Maybe Ident) (Maybe AExp) + | SavepointStat Ident + | FetchStat Ident [Ident] AExp + | LockTableStat [Ident] [String] Bool + | CloseStat Ident + | SetTranStat String [String] (Maybe Ident) (Maybe AExp) + | ProcedureCall ProcCall + | OpenCurStat ProcCall + | DynOpenCurForStat Ident AExp + | OpenCurForStat Ident Select + | SelectStat Select + | ExecStat AExp + | UpdateStat FromClause WhereClause SetClause CurrentOf ReturnClause + | DeleteStat FromClause WhereClause CurrentOf ReturnClause + | InsertStat Ident InsertColClause InsertValClause ReturnClause + | InsertSelectStat Ident InsertColClause ReturnClause Select + deriving (Eq) + + +data BlockStat + = If (Seq If') + | Case (Seq If') Label + | CaseOf AExp (Seq CaseOf') Label + | Loop (Seq Stat) Label + | While AExp (Seq Stat) Label + | For Ident Bool AExp AExp (Seq Stat) Label + | ForCur Ident ProcCall (Seq Stat) Label + | ForSelect Ident Select (Seq Stat) Label + | Block (Seq Dec) (Seq Stat) (Maybe (Seq Handler)) Label +-- | ProcCall [AExp] + deriving (Eq) + +data Seq a = Seq [a] Label + deriving (Eq) + +emptySeq = Seq [] noLabel + +data Label = Label (Maybe Ident) + deriving (Eq) + +noLabel = Label Nothing + +data PlType + = PlScalar Ident [AExp] + | Anchored Ident + | RowAnchored Ident +-- | PlRecord PlTypeName [PlType] +-- | PlTable PlTypeName PlTypeName + deriving (Eq) + +-------------------------------------------------------------------------------- +-- Display Functions +-------------------------------------------------------------------------------- +nullStatOnly = Seq [NullStat] noLabel + +br = (++"
") + +td :: [String] -> String +td xs = hWrap ("") "" xs + +tr :: [String] -> String +tr = hWrap "" "" + +tbl :: [String] -> String +tbl = hWrap "" "
" + +hWrap tag eTag xs = foldl (++) "" (map ((tag++) . (++eTag)) xs) + +delimit c arr = dropWhile (==c) $ foldl (++) [c] (map ((c:) . show) arr) + +delimitString c arr = dropWhile (==c) $ foldl (++) [c] (map ((c:)) arr) + +replace :: Eq a => a-> [a] -> [a] -> [a] +replace f t s = foldl1 (\x y -> x ++ t ++ y) (filter (/=[f]) ( groupBy (\a b -> a/=f && b/=f) s ) ) + +escapeList l = foldl1 (.) (map (\(x,y) -> replace x y) l) + +escapeHtml = escapeList [ ('<', "<"), ('>', ">") ] + +chkLabelMatch (Label l) (Label el) + = (if l'==el' then l' else mismatch) + where l' = (showMaybe l) + el' = (showMaybe el) + mismatch = err l' ++ (eMsgLabelMismatch) ++ (err el') + + +--showMaybeS :: (Maybe String) -> String +--showMaybeS (Just a) = a +--showMaybeS Nothing = "" + +showMaybe :: Show a => (Maybe a) -> String +showMaybe (Just a) = show a +showMaybe Nothing = "" + +showMaybePre :: Show a => String -> (Maybe a) -> String +showMaybePre pre (Just a) = pre ++ ' ': show a +showMaybePre _ Nothing = "" + + +eMsgLabelMismatch = errLink "#top" "End Label Mismatch: " +eUnqualified = errLink "#top" "Unqaulified identifier in SQL" +eGoto = errLink "#top" "GOTO" +eWhenOthersNull = errLink "#top" "WHEN OTHERS NULL" +eRbackSegment = errLink "#top" "ROLLBACK SEGMENT" +eFunkyCommit = errLink "#top" "UNSAFE COMMIT" +eForceTranControl = errLink "#top" "FORCE IN COMMIT/ROLLBACK" +eCommitScn = errLink "#top" "COMMIT WITH SCN" +eDynamicOpen = errLink "#top" "DYNAMIC OPEN CURSOR " +eExecuteImmediate = errLink "#top" "EXECUTE IMMEDIATE " + +wWhenOthers = warnLink "#top" "OTHERS" +wNoDefault = warnLink "#top" "NO DEFAULT" +wPragma = warnLink "#top" "PRAGMA" +wLock = warnLink "#top" "LOCK " +wPipelined = warnLink "#top" "PIPELINED " + + +link :: (String -> String) -> String -> String -> String +link f href text = " " ++ (f text) ++ "" + +errLink = link err + +warnLink = link warn + + +err x = "" ++ x ++ "" + +warn x = "" ++ x ++ "" + + +instance Show Label where + show (Label (Just l)) = show l + show _ = "" + + +instance Show If' where + show (If' bex s) = showSeq s noLabel (escapeHtml (show bex)) + +instance Show CaseOf' where + show (CaseOf' aex s) = showSeq s noLabel (show aex) + +instance Show Handler where + show (Handler i s) = showSeq s noLabel (if (elem (NIdent "OTHERS" "") i) then (if s == nullStatOnly then eWhenOthersNull else wWhenOthers) + else delimit '|' i + ) + +instance Show Stat where + show (Assign v a) = br$ show v ++ " := " ++ " (" ++ (show a) ++ ")" + show (Exit b l) = br$ "EXIT " ++ show l ++ " WHEN " ++ show b + show (Goto l) = br$ eGoto ++ show l + show (ReturnStat) = "RETURN
" + show (ReturnValueStat v) = br$ "RETURN " ++ show v + show (BlockWrap n b) = show b + show (NullStat) = "NULL
" + show (RaiseStat i) = br$ "RAISE " ++ showMaybe i + show (CommitStat com wModes frc scn) = br$ "COMMIT " ++ showMaybe com + ++ (if (length wModes) > 0 then eFunkyCommit else "") + ++ delimitString ' ' wModes + ++ ' ' : showMaybePre eForceTranControl frc + ++ ' ' : showMaybePre eCommitScn scn + show (RollbackStat toSav frc) = br$ "ROLLBACK " ++ showMaybe toSav + ++ ' ' : showMaybePre eForceTranControl frc + show (SavepointStat i) = br $ "SAVEPOINT " ++ show i + show (FetchStat cur vars lim) = br $ "FETCH" ++ "[" ++ show lim ++ "] " ++ show cur ++ "→" ++ delimit ',' vars + show (LockTableStat tab mode nowait) = br$ wLock ++ delimit ',' tab ++ ' ': delimitString ' ' mode ++ if nowait then " NOWAIT" else "" + show (CloseStat i) = br $ "CLOSE " ++ show i + show (SetTranStat rm isos rback name) = br$ "SET TRAN " ++ (if rm == "" then "" else "READ " ++ rm) + ++ delimitString ' ' isos + ++ showMaybePre eRbackSegment rback + ++ ' ' : showMaybe name + show (ProcedureCall p) = br$ show p + show (OpenCurStat p) = br$ "OPEN " ++ show p + show (SelectStat s) = br$ show s + show (DynOpenCurForStat cur a) = br$ eDynamicOpen ++ show a + show (OpenCurForStat cur sel) = br$ "OPEN " ++ show cur ++ " FOR " ++ show sel + show (ExecStat e) = br$ eExecuteImmediate ++ show e + show (UpdateStat frm whr set cur rtn) = + tbl [ tr [ td [ "update " , ""] + , td [ "from" , show frm ] + , td [ "where" , show whr ] + , if cur == Nothing then "" else td [ "CURRENT OF" , show cur ] + , td [ "set" , show set ] + , td [ "returning" , show rtn ] + ] + ] + show (DeleteStat frm whr cur rtn) = + tbl [ tr [ td [ "delete " , ""] + , td [ "from" , show frm ] + , td [ "where" , show whr ] + , if cur == Nothing then "" else td [ "CURRENT OF" , show cur ] + , td [ "returning" , show rtn ] + ] + ] + show (InsertStat tab col val rtn) = + tbl [ tr [ td [ "insert " , show tab ] + , td [ "into" , show col ] + , td [ "values" , show val ] + , td [ "returning" , show rtn ] + ] + ] + show (InsertSelectStat tab col rtn sel) = + tbl [ tr [ td [ "insert " , show tab ] + , td [ "into" , show col ] + , td [ "returning" , show rtn ] + , td [ show sel ] + ] + ] + show _ = "??? Stat" + + + +instance Show BlockStat where + show (Block decs body excps l) = showSeqs body l [show decs, showMaybe excps] + show (If elsifs) = showSeqs elsifs noLabel ["IF"] + show (Case cases l) = showSeqs cases l ["CASE"] + show (CaseOf a cases l) = showSeqs cases l ["CASE OF", show a] + show (Loop s l) = showSeqs s l ["LOOP"] + show (While cond s l) = showSeqs s l ["WHILE", escapeHtml (show cond) ] + show (For i rev low high s l) = showSeqs s l ["FOR " ++ show i + , if rev then show high ++ "←" ++ show low + else show low ++ "→" ++ show high + ] + show (ForCur i p s l) = showSeqs s l ["For " ++ show i + , show p + ] + show (ForSelect i sel s l) = showSeqs s l ["For " ++ show i + , show sel + ] + show _ = "??? blockstat" + + +showSeq :: Show a => (Seq a) -> Label -> String -> String +showSeq (Seq s l) el t = tbl [ tr [ td [ br$ chkLabelMatch l el ++ t ++ " ", foldl (++) "" (map show s) ] ] ] + + +showSeqs :: Show a => (Seq a) -> Label -> [String] -> String +showSeqs s el t = showSeq s el (foldl1 (\x y -> if y /= "" then x ++ "
" ++ y else x) t) + +instance Show a => Show (Seq a) where + show (Seq s l) = tbl [ tr [ td [ " ", foldl (++) "" (map show s)] ] ] + +instance Show Dec where + show (VarDec i ref t constant nullable defaultVal) = br$ show i + ++ ' ' : ref + ++ ' ' : (show t) + ++ (if constant then " CONSTANT " else "") + ++ (if not nullable then " NOT NULL " else "") + ++ " := " + ++ show defaultVal + show (Pragma i args) = br$ (if i == (NIdent "EXCEPTION_INIT" "") then "PRAGMA " else wPragma) ++ show i ++ show args + show (RecordDec name attribs) = showSeqs attribs noLabel ["RECORD", show name] + show (TableDec name tabType indType n) = br$ show name ++ ' ' : show tabType ++ '[' : showMaybe indType ++ "]" + ++ (if not n then " NOT NULL " else "") + show (VarrayDec name tabType len n) = br$ show name ++ ' ' : show tabType ++ '[' : show len ++ "]" + ++ (if not n then " NOT NULL " else "") + show (ProcedureSpecDec name args retType pipelined) = showSeqs args noLabel + ["PROCEDURE" + , (if pipelined == "" then "" else wPipelined) + , show name + , "RETURN " ++ showMaybe retType + ] + show (DecWithBody spec body) = show spec ++ show body + show (DecWithSelect spec sel) = show spec ++ show sel + + +instance Show Ident where + show (NIdent s c) = (if c == "sql" then eUnqualified else "") ++ map toUpper s + show (QIdent s c) = (if c == "sql" then eUnqualified else "") ++ show s + show (QualIdent s c) = delimit ':' s + + + +instance Show AExp where + show (Var a) = show a + show (IntLit a) = show a + show (StringLit a) = '\'' : (a ++ "\'") + show (AOp o l r) = show l ++ (' ':(if o == "**" then "^" else o)) ++ (' ':(show r)) + show (AUnOp o l) = show l ++ (' ':o) + show (NullLiteral) = "NULL" + show (DummyAExp context) = if context == "varDec" then wNoDefault else "NULL" + show (BUnOp o r) = o ++ show r + show (BoolLit b) = show b + show (NullBoolLit) = "NULL" + show (BOp o l r) = show l ++ (' ':o) ++ (' ':(show r)) + show (RelOp o l r) = show l ++ (' ':o) ++ (' ':(show r)) + show (RelUnOp o l) = show l ++ (' ':o) + show (AExpList pref a) = pref ++ '(' : delimit ',' a ++ ")" + show (FunctionCall p) = show p + show (NestedSelect s) = show s + show (BetweenExpr v l h) = '(': (show l) ++ '<': (show v) ++ '<': show h + + +instance Show PlType where + show (PlScalar name modifiers) = show name ++ if modifiers == [] then "" else '(' : delimit ',' modifiers ++ ")" + show (Anchored name) = show name ++ "%TYPE" + show (RowAnchored name) = show name ++ "%ROWTYPE" + +instance Show ActualParam where + show (UnNamedParam a) = show a + show (NamedParam name a) = show name ++ "←" ++ show a + +instance Show SqlExp where + show (UnNamedSqlExp a) = show a + show (NamedSqlExp a name) = show name ++ " AS " ++ show a + + +instance Show ProcCall where + show (ProcCall i (Seq as _)) = show i ++ '(' : delimit ',' as ++ ")" + +instance Show Select where + show (Select dist cols blk into frm whr grp hav oby rtn wth setOps) + = let showOp (SetOp op sel oby) = td [op, show sel] ++ (tr [td ["order by", show oby]]) + showOps s = map showOp s + in tbl [ tr ([ td [ "select " ++ dist , show cols] + , td [ "bulk collect" , show blk ] + , td [ "into" , show into] + , td [ "from" , show frm ] + , td [ "where" , show whr ] + , td [ "group by" , show grp ] + , td [ "having" , show hav ] + , td [ "order by" , show oby ] + , td [ "returning" , show rtn ] + , td [ "with" , show wth ] + ] ++ (showOps setOps) + ) + ] + + +instance Show BasicSqlClause where + show (BasicSqlClause e) = showMaybe e + + +instance Show WithClause where + show (WithClause cs) = let tabify (i,e) = tbl [ tr [ td [show i, show e] ] ] + in foldl (++) "" (map tabify cs) + + +instance Show FormalParam where + show (FormalParam i mode ref t nullable defaultVal) = br$ delimitString ' ' [ show i, mode, ref, show t + , if not nullable then " NOT NULL " else "" + , " := ", show defaultVal + ] + diff --git a/plsl_lint/Plsl_parse.hs b/plsl_lint/Plsl_parse.hs new file mode 100644 --- /dev/null +++ b/plsl_lint/Plsl_parse.hs @@ -0,0 +1,1063 @@ +module Plsl_parse( prettyWhileFromFile ) where + +{- +Copyright (c) 2008, Larry Layland +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of the plsl_lint nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + + +{-------------------------------------------------------------------------------------------------------- + - PL_LINT - a lint for pl/sql with html output + - + - Still to do: + - - cursor variables + - - views + - - triggers + - - insert statement - insert all + - - merge statement + - - execute immediate - using and into clauses + - - interval literals + - - open-for statement - using clause + - - sql cursor - cursor attribute %bulk_rowcount(index) + - - cursor attribute %bulk_exceptions(index).[error_index|errorCode] + - - select - + - - ansi joins + - - analytics + - - grouping sets, cube, rollup + - - model clause (I don't really want to bother with this one) + - - partition syntax in from clause -- may already work + - - returning into cluase - need to test + - - order clause - siblings + - - nulls [first|last] + - + - + -------------------------------------------------------------------------------------------------------} + +import Plsl_ast +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language( javaStyle ) +import Maybe +import System +import Data.Char + + +prettyWhileFromFile fname oname + = do{ input <- readFile fname +-- ; putStr input + ; putStr ("Parsing: " ++ fname ++ " ... \n") + ; case runParser program "plsql" fname input of + Left err -> do{ putStr "parse error at " + ; print err + } + Right x -> (do{ writeFile oname $ show x + ; putStr ("Output Written to: " ++ oname ++ "\n") + ; eCode <- system oname + ; return () + } + ) + } + +type GP = GenParser Char Context + +--program :: GP Program +program = do{ try whiteSpace + ; option () cr + ; b <- choice [ embed ProgramStat block "block" + , embed ProgramDec function "function" + , embed ProgramDec procedure "procedure" + , embed ProgramDec package "package" + ] +-- ; b <- embed ProgramStat block + ; semi + ; option () (reservedOp "/") + ; eof + ; return $ b + } + where cr = do{ reserved "create" + ; reservedIgnore "or" + ; reservedIgnore "replace" + } + + + +select = select' True + +select' :: Bool -> GP Select +select' doOp = do{ ; prevContext <- getState; setState "sql" + ; wths <- option (WithClause []) withClause + ; reserved "select" + ; dist <- option "" (choice [ reservedRet "distinct" + , reservedRet "unique" + , reservedRet "all" + ] + ) + ; cols <- sepBy1 sqlExp comma + ; blk <- getClause ["bulk", "collect", "into"] + ; into <- getClause ["into"] ; setState "from clause" + ; frm <- getClause ["from"] ; setState "sql" + ; whr <- getClause ["where"] + ; grp <- getClause ["group", "by"] + ; hav <- getClause ["having"] + ; oby <- getClause ["order", "by"] + ; rtn <- getClause ["returning"] + ; setOps <- if doOp then option [] (many1 setOp) else return [] ; setState prevContext + ; return $ Select dist cols (bs blk) (bs into) (FromClause frm) (bs whr) + (bs grp) (bs hav) (bs oby) (bs rtn) + wths setOps + } + +ignore igs = foldl1 (>>) (map (try . reserved) igs) + +bs c = BasicSqlClause (if c == [] then Nothing else Just c) + +getClause igs = do{ clause <- try $ option [] $ (ignore igs) >> (sepBy1 sqlExp comma) + ; return clause + } + +setOp = do{ op <- choice [ try ( do{ try (reserved "union"); reserved "all"; return "union all"}) + , reservedRet "intersect" + , reservedRet "minus" + , try (reservedRet "union") + ] + ; sel <- choice [ try$ select' False, try$ parens select] + ; oby <- getClause ["order", "by"] + ; return $ SetOp op sel (bs oby) + } + +withClause = do{ reserved "with" + ; withs <- sepBy1 withClause' comma + ; return $ WithClause withs + } + +withClause' = do{ i <- unQualIdentifier + ; reserved "as" + ; e <- sqlExp + ; return ( (i "with clause") , e) + } + + +updateStat :: GP Stat +updateStat = do{ reserved "update" ; prevContext <- getState; setState "from clause" + ; frm <- option [] (sepBy1 sqlExp comma) ; setState "sql" + ; set <- getClause ["set"] + ; cur <- option Nothing (try currentOf) + ; whr <- getClause ["where"] + ; rtn <- getClause ["returning"] ; setState prevContext + ; return $ UpdateStat (FromClause frm) (bs whr) (bs set) cur (bs rtn) + } + +deleteStat :: GP Stat +deleteStat = do{ reserved "delete" ; prevContext <- getState; setState "from clause" + ; option () (reserved "from") + ; frm <- option [] (sepBy1 sqlExp comma) ; setState "sql" + ; whr <- getClause ["where"] + ; cur <- option Nothing (try currentOf) + ; rtn <- getClause ["returning"] ; setState prevContext + ; return $ DeleteStat (FromClause frm) (bs whr) cur (bs rtn) + } + +insertStat :: GP Stat +insertStat = do{ reserved "insert" ; prevContext <- getState + ; reserved "into" ; setState "insert table" + ; tab <- plIdentifier ; setState "insert list" + ; cols <- parens (sepBy1 sqlExp comma) ; setState "sql" + ; reserved "values" + ; vals <- parens (sepBy1 sqlExp comma) + ; rtn <- getClause ["returning"] ; setState prevContext + ; return $ InsertStat tab (bs cols) (bs vals) (bs rtn) + } + +insertSelectStat :: GP Stat +insertSelectStat = do{ reserved "insert" ; prevContext <- getState + ; reserved "into" ; setState "insert table" + ; tab <- plIdentifier ; setState "insert list" + ; cols <- parens (sepBy1 sqlExp comma) ; setState "sql" + ; sel <- select + ; rtn <- getClause ["returning"] ; setState prevContext + ; return $ InsertSelectStat tab (bs cols) (bs rtn) sel + } + +currentOf = do{ try $ reserved "where" + ; reserved "current" + ; reserved "of" + ; i <- plIdentifier + ; return $ Just i + } + +sLabel :: GP Label +sLabel = do{ sl <- option (Label Nothing) (do{ symbol "<<" + ; l <- unQualIdentifier + ; symbol ">>" + ; return $ Label (Just (l "label")) + } + ) + ; return sl + } + +endLabel :: GP Label +endLabel = do{ l <- option Nothing (do {l' <- try unQualIdentifier; return (Just (l' "endlabel"))} ) + ; return $ Label l + } + + +pragmaDec = do{ reserved "pragma" + ; i <- simpleIdentifier + ; args <- option [] anyParen + ; return $ Pragma (i "pragma") args + } + +anyParen = do{ symbol "(" + ; a <- many (try $ satisfy (\x -> x /= ')')) + ; symbol ")" + ; return a + } + +varrayDec = do{ reserved "type" + ; name <- unQualIdentifier + ; reserved "is" + ; choice [reserved "varray", reserved "varying" >> reserved "array"] + ; len <- parens intLiteral + ; reserved "of" + ; tabType <- plIdentifier + ; tabModifiers <- option [] ( parens (sepBy1 intLiteral comma) ) + ; nullable <- option True (reserved "not" >> reserved "null" >> return False) + ; return $ VarrayDec (name "varray dec") (PlScalar tabType tabModifiers) len nullable + } + +tableDec = do{ reserved "type" + ; name <- unQualIdentifier + ; reserved "is" + ; reserved "table" + ; reserved "of" + ; tabType <- plIdentifier + ; tabModifiers <- option [] ( parens (sepBy1 intLiteral comma) ) + ; iBy <- option Nothing indexBy + ; nullable <- option True (reserved "not" >> reserved "null" >> return False) + ; return $ TableDec (name "table dec") (PlScalar tabType tabModifiers) iBy nullable + } + where indexBy = do{ + ; reserved "index" + ; reserved "by" + ; indType <- plIdentifier + ; indModifiers <- option [] ( parens (sepBy1 intLiteral comma) ) + ; return $ Just (PlScalar indType indModifiers) + } + +recordDec = do{ reserved "type" + ; name <- unQualIdentifier + ; reserved "is" + ; reserved "record" + ; prevState <- getState; setState "record dec" + ; attribs <- parens ( sepBy1 varDec comma) + ; setState prevState + ; return $ RecordDec (name "record dec") (Seq attribs noLabel) + } + +inOut = do{ i <- option "" $ reservedRet "IN" + ; o <- option "" $ reservedRet "OUT" + ; c <- option "" $ reservedRet "NOCOPY" + ; return $ (if i == "" then if o == "" then "IN " else "OUT " else "IN " ++ o) ++ c + } + +formalParam = do { name <- unQualIdentifier + ; mode <- inOut + ; ref <- option "" (reservedRet "ref") + ; t <- plIdentifier + ; anch <- option False (reserved "%TYPE" >> return True) + ; rowAnch <- option False (reserved "%ROWTYPE" >> return True) + ; nullable <- option True (reserved "not" >> reserved "null" >> return False) + ; defaultVal <- option (DummyAExp "formal param") defaultExpr + ; return $ FormalParam (name "formal param") + mode + ref + (if rowAnch then RowAnchored t else if anch then Anchored t else PlScalar t []) + nullable + defaultVal + } + +formalParamList :: GP [FormalParam] +formalParamList = do{ ps <- parens $ sepBy formalParam comma + ; return ps + } + + +cursor :: GP Dec +cursor = do{ spec <- cursorSpec + ; reserved "is" + ; sel <- select + ; return $ DecWithSelect spec sel + } + + +cursorSpec :: GP Dec +cursorSpec = procedureSpec' "cursor" + +functionSpec :: GP Dec +functionSpec = procedureSpec' "function" + + +function :: GP Dec +function = do{ spec <- functionSpec + ; body <- procedureBody $ getLabel spec + ; return $ DecWithBody spec body + } + where getLabel (ProcedureSpecDec name _ _ _) = name + +package :: GP Dec +package = do{ spec <- procedureSpec' "package" + ; body <- procedureBody $ getLabel spec + ; return $ DecWithBody spec body + } + where getLabel (ProcedureSpecDec name _ _ _) = name + + +procedureSpec = procedureSpec' "procedure" + +procedureSpec' :: String -> GP Dec +procedureSpec' start = do{ reserved start + ; reservedIgnore "body" -- hack for package bodies + ; name <- plIdentifier -- was unQualIdentifier but needs to be qualifiable in create statements + ; args <- option [] ( try formalParamList) + ; retType <- option Nothing (do{reserved "return"; retType <- plIdentifier; return $ Just retType}) + ; reservedIgnore "deterministic" + ; reservedIgnore "parallel_enable" + ; reservedIgnore "deterministic" + ; reservedIgnore "authid" + ; reservedIgnore "current_user" + ; reservedIgnore "definer" + ; pipelined <- option "" (reservedRet "pipelined") + ; return $ ProcedureSpecDec (Label (Just (name {-"label"-}))) (Seq args noLabel) retType pipelined + } + +procedure :: GP Dec +procedure = do{ spec <- procedureSpec + ; body <- procedureBody $ getLabel spec + ; return $ DecWithBody spec body + } + where getLabel (ProcedureSpecDec name _ _ _) = name + +procedureBody :: Label -> GP BlockStat +procedureBody l = do { d <- option (Seq [] noLabel) (dec ["is","as"]) + ; b <- option (Seq [] noLabel) (try body) + ; h <- handler + ; reserved "end" + ; el <- endLabel + ; return $ Block d b h el + } + where body = do{ reserved "begin"; stats <- seqStat l; return stats } + + +dec :: [String] -> GP (Seq Dec) +dec startWords = do{ choice (map reserved startWords) + ; d <- endBy dec' semi + ; return $ Seq d noLabel + } + +dec' = choice [ varDec + , try procedure <|> try procedureSpec + , try function + , try functionSpec + , try cursor + , try cursorSpec + , pragmaDec + , try recordDec + , try tableDec + , try varrayDec + ] + + + +varDec :: GP Dec +varDec = do{ context <- getState + ; id <- plIdentifier + ; ref <- option "" (reservedRet "ref") + ; constant <- option False (reserved "constant" >> return True) + ; t <- choice [ plIdentifier, embed (\x -> NIdent x "exception dec") (reservedRet "exception") ] + ; modifiers <- option [] ( parens (sepBy1 intLiteral comma) ) + ; anch <- option False (reserved "%TYPE" >> return True) + ; rowAnch <- option False (reserved "%ROWTYPE" >> return True) + ; nullable <- option True (reserved "not" >> reserved "null" >> return False) + ; defaultVal <- option (DummyAExp (if context /= "record dec" then "varDec" else context)) defaultExpr + ; return $ VarDec id + ref + (if rowAnch then RowAnchored t else if anch then Anchored t else PlScalar t modifiers) + constant + nullable + defaultVal + } + +defaultExpr :: GP AExp +defaultExpr = do{ choice [reservedOp ":=", reserved "default"] + ; a <- expr + ; return a + } + +plIdentifier :: GP Ident +plIdentifier = qualIdentifier + +qualIdentifier :: GP Ident +qualIdentifier = do{ context <- getState + ; i <- sepBy1 unQualIdentifier singleDot + ; return $ if length i == 1 then head i context else QualIdent (fmap ($ "Qualified") i ) context + } + +unQualIdentifier :: GP (Context -> Ident) +unQualIdentifier = do{ i <- choice [starIdentifier, quoteIdentifier, simpleIdentifier] + ; return $ i + } + +starIdentifier :: GP (Context -> Ident) +starIdentifier = do{ symbol "*"; return $ QIdent "*" } + +simpleIdentifier :: GP (Context -> Ident) +simpleIdentifier = do{ i <- identifier; return $ NIdent i } + +quoteIdentifier :: GP (Context -> Ident) +quoteIdentifier = do{ i <- qIdentifier; return $ QIdent i } + +stat :: GP Stat +stat = choice [ try block + , try execStat + , try ifStat + , try caseStat + , try caseOfStat + , try whileStat + , try loopStat + , try forStat + , try forSelectStat + , try forCurStat + , try exitStat + , try gotoStat + , try returnValueStat + , try returnStat + , try assignStat + , try raiseStat + , try savepointStat + , try rollbackStat + , try commitStat + , try fetchStat + , try lockTableStat + , try closeStat + , try setTranStat + , try openCurForStat + , try dynOpenCurForStat + , try openCurStat + , try $ embed SelectStat select + , try updateStat + , try deleteStat + , try insertStat + , try insertSelectStat + , try (reserved "null" >> return NullStat) + , try procedureCall + , do{ proc <- plIdentifier; return $ ProcedureCall $ ProcCall proc emptySeq} + -- yeah this last choice is dumb but I needed a hack for procedures with no parens + ] + + + +execStat = do{ reserved "execute" + ; reserved "immediate" + ; e <- expr + ; return $ ExecStat e + } + +openCurStat = do{ try $ reserved "open" + ; p <- choice [try procCall, hack] + ; return $ OpenCurStat p + } + where hack = do{ i <- unQualIdentifier; return $ ProcCall (i "proc call") (Seq [] noLabel)} + -- hack is a workaround for procCall having the paren list optional + +dynOpenCurForStat = do { try $ reserved "open" + ; cur <- unQualIdentifier + ; reserved "for" + ; e <- expr + ; return $ DynOpenCurForStat (cur "open for") e + } + +openCurForStat = do { try $ reserved "open" + ; cur <- unQualIdentifier + ; reserved "for" + ; sel <- select + ; return $ OpenCurForStat (cur "open for") sel + } + +setTranStat :: GP Stat +setTranStat = do{ reserved "set" + ; reserved "transaction" + ; readMode <- option "" (do{ reserved "read" + ; r <- choice [reservedRet "only", reservedRet "write"] + ; return r + } + ) + ; iso <- option [""] (do{ reserved "isolation" + ; reserved "level" + ; i <- choice [ count 1 (reservedRet "serializable") + , count 2 (choice [reservedRet "read", reservedRet "committed"]) + ] + ; return i + } + ) + ; rback <- option Nothing (do{ reserved "use" + ; reserved "rollback" + ; reserved "segment" + ; rb <- unQualIdentifier + ; return $ Just (rb "set tran rollback") + } + ) + ; name <- option Nothing + (do{ reserved "name" + ; n <- aritExpr + ; return $ Just n + } + ) + ; return $ SetTranStat readMode iso rback name + } + + +closeStat :: GP Stat +closeStat = do{ reserved "close" + ; i <- plIdentifier + ; return $ CloseStat i + } + +lockTableStat :: GP Stat +lockTableStat = do{ reserved "lock" + ; reserved "table" + ; tab <- sepBy1 plIdentifier comma + ; reserved "in" + ; mode <- sepBy1 (choice [reservedRet "SHARE", reservedRet "EXCLUSIVE", reservedRet "UPDATE", reservedRet "ROW"]) whiteSpace + ; reserved "mode" + ; nowait <- option False (reserved "nowait" >> return True) + ; return $ LockTableStat tab mode nowait + } + + +fetchStat :: GP Stat +fetchStat = do{ reserved "fetch" + ; cur <- plIdentifier + ; lim' <- option 1 (reserved "bulk" >> return 0) + ; reservedIgnore "collect" + ; reserved "into" + ; vars <- sepBy1 plIdentifier comma + ; lim <- option (DummyAExp "limit") (do {reserved "limit"; i <- aritExpr; return i}) + ; return $ FetchStat cur vars (if lim' == 1 then (IntLit 1) else lim ) + } + + +commitStat :: GP Stat +commitStat = do{ reserved "commit" + ; reservedIgnore "work" + ; com <- option Nothing (do{ reserved "comment"; a <- stringLiteral; return $ Just a}) + ; reservedIgnore "write" + ; wMode <- option [] (many1 (choice [reservedRet "immediate", reservedRet "batch", reservedRet "wait", reservedRet "nowait"])) + ; frc <- option Nothing (do{ reserved "force"; a <- stringLiteral; return $ Just a}) + ; scn <- option Nothing (do{ i <- intLiteral; return $ Just i}) + ; return $ CommitStat com wMode frc scn + } + + +rollbackStat :: GP Stat +rollbackStat = do{ reserved "rollback" + ; reservedIgnore "work" + ; toSav <- option Nothing (do{ reserved "to"; a <- unQualIdentifier; return $ Just (a "rollback") }) + ; frc <- option Nothing (do{ reserved "force"; a <- stringLiteral; return $ Just a}) + ; return $ RollbackStat toSav frc + } + +savepointStat :: GP Stat +savepointStat = do{ reserved "savepoint" + ; i <- unQualIdentifier + ; return $ SavepointStat (i "savepoint") + } + +raiseStat :: GP Stat +raiseStat = do{ reserved "raise" + ; i <- option Nothing (do{i <- plIdentifier; return $ Just i}) + ; return $ RaiseStat i + } + +returnStat :: GP Stat +returnStat = do{ reserved "return" + ; return ReturnStat + } + +returnValueStat :: GP Stat +returnValueStat = do{ reserved "return" + ; e <- expr + ; return $ ReturnValueStat e + } + +assignStat :: GP Stat +assignStat = assignStat' ":=" + +assignStat' :: String -> GP Stat +--assignStat' eq = do{ id <- plIdentifier +assignStat' eq = do{ id <- expr + ; symbol eq + ; e <- expr + ; return $ Assign id e + } + +exitStat :: GP Stat +exitStat = choice [try (do{ reserved "exit" + ; l <- option noLabel endLabel + ; reserved "when" + ; b <- boolExpr + ; return $ Exit b l + }) + ,try (do{ reserved "exit" + ; l <- option noLabel endLabel + ; return $ Exit (BoolLit True) l + }) + ] + +gotoStat :: GP Stat +gotoStat = do { reserved "goto" + ; l <- endLabel + ; return $ Goto l + } + +block :: GP Stat +block = do{ l <- sLabel + ; d <- option (Seq [] noLabel) (dec ["declare"]) + ; reserved "begin" + ; stats <- seqStat l + ; h <- handler + ; reserved "end" + ; el <- endLabel + ; return $ BlockWrap l (Block d stats h el) + } + +ifStat :: GP Stat +ifStat = do{ l <- sLabel + ; reserved "if" + ; cond <- boolExpr + ; reserved "then" + ; thenPart <- seqStat noLabel + ; elseIfPart <- try $ many (elseIfPiece "elsif") + ; elsePart <- try $ option [] elsePiece + ; reserved "end"; reserved "if" + ; return $ BlockWrap l + (If (Seq ((If' cond thenPart) : elseIfPart ++ elsePart) + noLabel + ) + ) + } + +caseStat :: GP Stat +caseStat = do{ l <- sLabel + ; reserved "case"; + ; elseIfPart <- many1 (elseIfPiece "when") + ; elsePart <- try $ option [] elsePiece + ; reserved "end"; reserved "case" + ; el <- endLabel + ; return $ BlockWrap l (Case (Seq( elseIfPart ++ elsePart) l ) el ) + } + +elseIfPiece :: String -> GP If' +elseIfPiece nextCond + = do { reserved nextCond + ; cond <- boolExpr + ; reserved "then" + ; s <- seqStat noLabel + ; return $ If' cond s + } + +elsePiece :: GP [If'] +elsePiece = do{ reserved "else" + ; s <- seqStat noLabel + ; return $ [If' (BoolLit True) s] + } + + +caseOfStat :: GP Stat +caseOfStat = do{ l <- sLabel + ; reserved "case" + ; switchOn <- aritExpr + ; cases <- many1 caseOfPiece + ; elseCase <- try $ option [] caseOfElsePiece + ; reserved "end"; reserved "case" + ; el <- endLabel + ; return $ BlockWrap l (CaseOf switchOn (Seq (cases ++ elseCase) l) el) + } + + +caseOfPiece :: GP CaseOf' +caseOfPiece = do{ reserved "when" + ; caseVal <- aritExpr + ; reserved "then" + ; s <- seqStat noLabel + ; return $ CaseOf' (Just caseVal) s + } + +caseOfElsePiece :: GP [CaseOf'] +caseOfElsePiece = do{ reserved "else" + ; s <- seqStat noLabel + ; return $ [CaseOf' Nothing s ] + } + +handler :: GP (Maybe (Seq Handler)) +handler = do{ h <- option Nothing (do {reserved "exception" + ; s <- many1 handlerPiece + ; return $ Just ((Seq s) noLabel) + } + ) + ; return h + } + +handlerPiece :: GP Handler +handlerPiece = do{ reserved "when" + ; i <- sepBy1 plIdentifier (reserved "or") + ; reserved "then" + ; stats <- seqStat noLabel + ; return $ Handler i stats + } + + +loopStat :: GP Stat +loopStat = do { l <- sLabel + ; reserved "loop" + ; body <- seqStat l + ; reserved "end"; reserved "loop" + ; el <- endLabel + ; return $ BlockWrap l (Loop body el) + } + + +whileStat :: GP Stat +whileStat = do{ l <- sLabel + ; reserved "while" + ; cond <- boolExpr + ; reserved "loop" + ; body <- seqStat l + ; reserved "end"; reserved "loop" + ; el <- endLabel + ; return $ BlockWrap l (While cond body el) + } + +forStat :: GP Stat +forStat = do { l <- sLabel + ; reserved "for" + ; i <- unQualIdentifier + ; reserved "in" + ; rev <- option False (try $ reserved "reverse" >> return True) + ; low <- aritExpr + ; symbol ".." + ; high <- aritExpr + ; reserved "loop" + ; body <- seqStat l + ; reserved "end"; reserved "loop" + ; el <- endLabel + ; return $ BlockWrap l (For (i "plsql") rev low high body el) + } + +forCurStat = do{ l <- sLabel + ; reserved "for" + ; i <- unQualIdentifier + ; reserved "in" + ; cur <- choice [try procCall, hack] + ; reserved "loop" + ; body <- seqStat l + ; reserved "end"; reserved "loop" + ; el <- endLabel + ; return $ BlockWrap l (ForCur (i "plsql") cur body el) + } + where hack = do{ i <- unQualIdentifier; return $ ProcCall (i "proc call") (Seq [] noLabel)} + -- hack is a workaround for procCall having the paren list optional + +forSelectStat = do{ l <- sLabel + ; reserved "for" + ; i <- unQualIdentifier + ; reserved "in" + ; sel <- parens select + ; reserved "loop" + ; body <- seqStat l + ; reserved "end"; reserved "loop" + ; el <- endLabel + ; return $ BlockWrap l (ForSelect (i "plsql") sel body el) + } + +seqStat :: Label -> GP (Seq Stat) +seqStat l = do{ stats <- sepEndBy1 stat semi + ; return $ Seq stats l + } + +procedureCall :: GP Stat +procedureCall = embed ProcedureCall procCall --do{ p <- procCall; return $ ProcedureCall p} + +functionCall :: GP AExp +functionCall = embed FunctionCall procCall -- do{ p <- procCall; return $ FunctionCall p} + +analyticClause = do{ reserved "over" + ; symbol "(" + ; part <- anaPartClause + ; ord <- getClause ["order","by"] + ; win <- anaWindowClause + ; return () -- $ AnalyticClause part ord win + } + +anaPartClause = return () + +anaWindowClause = return () + +procCall :: GP ProcCall +procCall = do{ --failOnReserved + ; proc <- plIdentifier -- unQualIdentifier -- not sure why I made this unQualIdentifier at first? +-- ; args <- option (Seq [] noLabel) actualParamList -- having this optional causes problems +-- -- function calls will be fine since they will look like variables +-- -- procedures calls we'll just have to live with enforcing empty parens + ; args <- try actualParamList + ; return $ ProcCall proc args + } + + +actualParamList :: GP (Seq ActualParam) +actualParamList = do{ +-- ps <- option [] (parens $ sepBy1 (choice [try namedParam, try unNamedParam]) comma) + ps <- parens $ option [] ( sepBy1 (choice [try namedParam, try unNamedParam]) comma) + ; return $ Seq (ps) noLabel + } + +unNamedParam = embed UnNamedParam expr -- do{ e <- expr; return $ UnNamedParam e} + +namedParam = do{ name <- unQualIdentifier + ; reservedOp "=>" + ; e <- expr + ; return $ NamedParam (name "named param") e + } + +sqlExp = choice [try namedSqlExp, unNamedSqlExp] + +unNamedSqlExp = embed UnNamedSqlExp expr -- do{ e <- expr; return $ UnNamedSqlExp e} + +namedSqlExp = do{ e <- expr + ; reservedIgnore "as" + ; name <- unQualIdentifier + ; return $ NamedSqlExp (name "sql alias") e + } + +expr = aritExpr +boolExpr = aritExpr + +aritExpr :: GP AExp +aritExpr = buildExpressionParser aritOperators simpleArit + + +-- Everything mapping pairs of ints to ints +aritOperators = + [ +-- [ op "." AssocLeft ] -- has strange bug where character after the dot has to be a 'v' +-- [ op "." AssocRight ] -- same bug +-- [ oprelv (try dot)] -- fixes above bug but breaks for loops with .. + [ Infix (singleDot >> return (\x y -> AOp "." x y) ) AssocLeft ] -- works for both for loops and v bug + , [ isNotNull, isNull] + , [ pct "%rowcount", pct "%bulk_rowcount", pct "%charset", pct "%found", pct "%notfound", pct "%isopen"] + , [ op "**" AssocLeft ] + , [ op "*" AssocLeft, op "/" AssocLeft ] + , [ op "+" AssocLeft, op "-" AssocLeft ] + , [ op "||" AssocLeft ] + , [ prefix "not"] + , [ opbb "and" AssocRight ] -- right for shortcircuit + , [ opbb "or" AssocRight ] -- right for shortcircuit + , [ oprel "<", oprel ">", oprel "<=", oprel ">="] + , [ oprel "=", oprel "<>", oprel "!=", oprel "^=" + , oprelv $ reservedRet "like", oprelv $ reservedRet "in", oprelv $ do { reserved "not"; reserved "in"; return "not in"} + ] + , [ oprelv $ reservedRet "between" ] +-- , [ opl "union", opl "intersect", opl "minus", unionAll] + ] + where +{- + opl name = Infix (do{ reserved name + ; return (\x y -> AOp name x y) + }) AssocLeft +-} + op name assoc = Infix (do{ reservedOp name + ; return (\x y -> AOp name x y) + }) assoc + pct suf = Postfix (do{ try $ reservedOp suf + ; return (\x -> AUnOp suf x) + } + ) + opbb name assoc = Infix (do{ reserved name + ; return (\x y -> BOp name x y) + }) assoc + oprel name = Infix (do{ reservedOp name + ; return (\x y -> RelOp name x y) + }) AssocLeft + oprelv pars = Infix (do{ name <- pars + ; return (\x y -> RelOp name x y) + }) AssocLeft + prefix name = Prefix (do{ reserved name + ; return (\x -> BUnOp name x) + }) + isNull = Postfix (do{ try ( reserved "is" >> reserved "null" ) + ; return (\x -> BUnOp "IS NULL:" x) + } + ) + isNotNull = Postfix (do{ try (reserved "is" >> reserved "not" >> reserved "null") + ; return (\x -> BUnOp "IS NOT NULL:" x) + } + ) +{- + unionAll = Infix (do{ try (try $ reserved "union" >> reserved "all") + ; return (\x y -> AOp "union all" x y) + }) AssocLeft +-} + +simpleArit = choice [ + try ( parens $ embed NestedSelect select ) +-- , try betweenExpr -- causes stack overflow + , try aritList + , try functionCall + , try aritListBare + , try intLiteral + , stringLiteral + , nullLiteral + , parens aritExpr + , embed Var plIdentifier --variable + , boolLiteral + ] + +aritList' :: GP [AExp] +aritList' = do{ symbol "(" + ; a <- aritExpr + ; comma + ; as <- sepBy1 aritExpr comma + ; symbol ")" + ; return $ (a:as) + } + +betweenExpr = do{ a <- aritExpr + ; reserved "between" + ; b <- aritExpr + ; reserved "and" + ; c <- aritExpr + ; return $ BetweenExpr a b c + } + +aritList :: GP AExp +aritList = do{ pref <- option "" (choice [reservedRet "any", reservedRet "all"]) + ; as <- aritList' + ; return $ AExpList pref as + } + +aritListBare :: GP AExp +aritListBare = do{ as <- aritList' + ; return $ AExpList "" as + } + + +boolLiteral = do{ reserved "false" + ; return (BoolLit False) + } + <|> + do{ reserved "true" + ; return (BoolLit True) + } + <|> + do{ reserved "null" + ; return (NullBoolLit) + } + +intLiteral = do{ i <- integer; return (IntLit i) } + +nullLiteral = do{ reserved "null"; + ; return NullLiteral + } + + +----------------------------------------------------------- +-- The lexer +----------------------------------------------------------- +lexer = P.makeTokenParser plDef + +plDef = javaStyle + { -- Kept the Java single line comments, but officially the language has no comments + P.reservedNames = reservedNames + , P.reservedOpNames= [ "<", "<=", ">", ">=", ":=", "+", "&", "-", "/", "||", "*", "**", "..", "." +-- leave these commented out for now as they cause problems (probably also the root of the v bug) +-- If we end up needing these then we need to populate P.opLetter with just the ones that are symbols only +-- , "%rowcount", "%bulk_rowcount", "%charset", "%found", "%notfound", "%isopen" + ] + , P.opLetter = oneOf (concat (P.reservedOpNames plDef)) + , P.caseSensitive = False + , P.commentLine = "--" + , P.identLetter = alphaNum <|> oneOf "_$#" + } + +reservedNames = [ "true", "false", "loop", "else", "not", "null", "constant" + , "if", "elsif", "then", "case", "when", "while" + , "declare", "begin", "procedure", "function", "return", "is", "end" + , "parallel_enable", "deterministic", "pipelined" + , "select", "from", "where", "group", "by", "order", "having", "as" + , "loop", "exit", "for", "in", "out", "nocopy", "ref" + , "raise" + , "<<", ">>" + , "pragma" + , "record","table", "type","index","by", "of", "varray", "varying", "array" + , "commit", "rollback" + , "work", "to", "force", "batch", "immdiate", "wait", "comment" + , "fetch", "into", "open", "close" + , "lock", "table", "row", "share", "exclusive", "update", "nowait" + , "set", "transaction", "only", "isolation" + , "serializable", "committed", "name", "use", "rollback", "segment" + , "returning", "the", "distinct", "unique" + , "bulk", "collect", "with", "union", "intersect", "minus" + , "create" --, "replace" -- Can't have replace as a reserved word because it is also a supplied function name -- brilliant + , "current", "values", "cursor", "between", "partition" + , "exception" + , "and", "or" + ,"caseZ" + ] + +parens = P.parens lexer +braces = P.braces lexer +semiSep1 = P.semiSep1 lexer +semi = P.semi lexer +comma = P.comma lexer +--dot = P.dot lexer +commaSep = P.commaSep lexer +whiteSpace = P.whiteSpace lexer +symbol = P.symbol lexer +identifier = P.identifier lexer +reserved = P.reserved lexer +reservedOp = P.reservedOp lexer +integer = P.integer lexer +charLiteral = P.charLiteral lexer + + + +qIdentifier = P.stringLiteral lexer + +stringLiteral + = do{ symbol "\'" + ; com <- manyTill (try (do {char '\''; char '\''}) <|> satisfy(\c -> c /= '\'')) (try endQoute) + ; return $ StringLit com + } + where endQoute = do{ symbol "\'"; notFollowedBy $ char '\''} + +reservedRet a = do{ try $ reserved a + ; return $ map toUpper a + } + +reservedIgnore s = option () (reserved s) + +--failOn ps = do{ foldl1 (>>) (map ( (>>pzero) . try . reserved) ps)} + +--failOnReserved = failOn reservedNames + +embed t p = (p >>= \x -> return $ t x) + +singleDot = try ( char '.' >> notFollowedBy (char '.') ) diff --git a/plsl_lint/test_files/test_pl.sql b/plsl_lint/test_files/test_pl.sql new file mode 100644 --- /dev/null +++ b/plsl_lint/test_files/test_pl.sql @@ -0,0 +1,306 @@ +-- create or replace package body test_pkg is +-- create or replace package test_pkg is +-- create or replace function test_func return number is +-- create or replace procedure test_proc is + declare + + + type rec is record (n number, d date, c char); + + type tab is table of number(4) index by varchar2(4); + type tab is table of number(4) index by varchar2(4) not null; + + type var is varray(10) of number(4); + type var is varray(10) of number(4) not null; + + procedure p( a in number, b in varchar2); + function f( a number, b out number, c in out number, d nocopy number) return number; + function f1 return number deterministic; + function f2 return number parallel_enable; + function f3 return number pipelined; + function f4 return number deterministic pipelined; + + a number; + a number(5); + a number(5,2); + b constant number ; + c constant number := 5; + d number default 5; + e number not null; + e constant number not null; + e number not null := true; + e constant number not null := 1+5; + r ref number; + + ex exception; + + pragma restrict_references; + pragma restrict_references(); + pragma exception_init(ex, -123456); + + a abc%type; + b abc%rowtype; + + cursor cur; + + cursor p( a in number, b in varchar2); + + cursor cur is select * from dual; + + cursor cur( a in number, b in varchar2) is select * from dual; + + procedure p( a in number, b in varchar2) + is + n number; + begin + return; + exception + when others then + a := a + 2**4; + end p; + + function f( a in number) + return number + is + retval number; + begin + return retval; + end f; +begin + null; + a := b(c).aval; --- Weird must have a v following the . + + a := b(c).val; + b(c).val := 1; + + a := c between 1 and 3; + select 1 into n + from dual where 2 between (1 and 3); + +-- abc(123).show; -- fails parse +-- a := abc(123).show; -- failse parse, will work if we add a "." operator but there has to be a space after the dot for some reason + + insert into tab (a,b,c) values (1,2,3); + + insert into tab (x,y,z) select 4,5,6 from dual; -- fails parse + + select * from dual; + + select a.*, b.* from dual a, dual b; + + update tab, tab2 set x = 3, y=4; + + update tab set x = 3 where current of cur; + + update tab set x = 3 where x=2; + + delete tab where x=2; + + delete from tab where x=2; + + + -- update tab set x = 3, y=4 where rownum = 1; + + execute immediate 'worse ' || than || 'goto'; + + for i in 1 .. 7 loop + a := i * n + 3; + end loop; + + for i in reverse 1 .. 7 loop + a := i * n + 3; + end loop; + + for i in cur loop + a := 1; + end loop; + + for i in cur(1,2,3) loop + a := 1; + end loop; + + for i in (select 1 from dual) loop + a := 2; + end loop; + + open cur for 'select 1 from dual'; + + open cur for select 1 from dual; + + open cur; + open cur(1,2); + open cur(1,a=>2); + + select 1 from dual + union + select 2 from dual + order by 1; + + select 1 a from dual + minus select 1 from dual + union all select 1 from dual + union select 1 from dual + intersect select 1 from dual + union (select 1 from dual minus select 1 from dual); + + select distinct a.c0, a.c1 as z1, a.c2 z1, c3, 3 + from a,b,c, + (select 1 a from dual); + + select a.c0, a.c1 as z1, a.c2 z1, c3, 3 + into p.a, p.b, c + from a,b,c, + (select 1 a from dual) + where 1=5 and a=4 + group by "a", a.b, a.c + having 1=5 and a=6 + order by a.a, a.b, c + returning a.a, a, 3; + + + select 1 + bulk collect into p.a + from dual + where d.dummy = (select dual.dummy from dual); + + select (select 1 n from dual) as a from dual; + + with a as (select 1 n from dual), + b as (select 1 o from dual) -- union select 2 o from dual) + select n from a; + + + + commit work; + commit comment 'done' write nowait; + commit write batch wait; + commit force 'distrib'; + commit force 'distrib' 55; + + + rollback; + rollback work to cya; + rollback force 'distrib'; + savepoint cya; + + a:=null; + a:=true; + + a := abc%found; + b := abc%notfound; + c := abc%isopen; + + d := 1 + abc%rowcount; + e := 2 + abc%bulk_rowcount; + f := 'a' + abc%charset; + + a := 1 > 3; + + a := ('abc') > ('123'); + a := 'abc' > '123'; + + a := 'abc' like 'a%'; + + a := (1,2,3); + a := 1 in (1,2,3); + a := 1 = any(1,2,3); + a := 1 = all(1,2,3); + + a := func(1); + a := func(1,3,4); + a := func(1,2, a=>1, b=>2); + a := func(a=>1, b=>2); + + a := f(1) + f2 / 3 / f3() = all ( f(4), f(a=>1), f(1,b=>2)); + + proc(); + proc(1,3,4); + proc(1,2, a => 1, b => 2); + proc(a=>1, b=>2); + + + fetch cur into var1, var2, var3; + fetch cur bulk collect into var1, var2, var3; + fetch cur bulk collect into var1, var2, var3 limit 10; + + close cur; + + set transaction read only; + set transaction read write name 'tweedle dee'; + set transaction isolation level serializable; + set transaction isolation level read committed name 'tweedle dum'; + set transaction use rollback segment "No Go"; + + + lock table a, scott.employee IN + ROW excLUSIVE Update + MODE nowait; + + begin + a:=1; + end; + + <> + begin + a:=1; + end; + + <> + begin + a:=1; + end match_label; + + <> + begin + a:=1; + end Zmismatch; + + begin + a:=1; + end no_start_label; + + loop + exit when true or false or null; + exit foobar when true or false or null; + a:=1; + end loop; + + return; + return (7+16); + return (True or false); + return True or false; + return 7>16; + return (7>16); + i := (true is not null); -- fails parse -- works now + return true is not null; -- fails parse -- works now + return i is null; + return i is not null; + + return (7>16) or (1>5) ; -- fails parse -- works now + return 'hi'; + return 'hi' || 'there'; + + + while true is null loop a := 1; end loop; + + a := 7 is null; + + while (1 > 4) loop a := 1; end loop; -- fails parse -- works now + + while (n is null) loop a := 1; end loop; -- fails parse -- works now + + goto "goto is bad m'kay"; + + +exception +when others then + a := 2; + null; +when no_data_found or b then + a := 3; + raise no_data_found; + raise; +when others or a then null; +end; + +