454 lines
15 KiB
FSharp
454 lines
15 KiB
FSharp
open System
|
|
open System.Diagnostics
|
|
open System.IO
|
|
open System.Reflection
|
|
|
|
exception UserError of string
|
|
|
|
type MutationCase =
|
|
{ Id: string
|
|
File: string
|
|
Line: int
|
|
Find: string
|
|
Replace: string
|
|
TestName: string
|
|
DeclaringType: string }
|
|
|
|
type MutationOutcome =
|
|
| Killed
|
|
| Survived
|
|
| BuildFailed
|
|
|
|
type Command =
|
|
| List
|
|
| Show of string
|
|
| Run of string list
|
|
|
|
type Options =
|
|
{ Configuration: string
|
|
ProjectPath: string
|
|
BuildArgs: string list
|
|
NoBuild: bool
|
|
Command: Command }
|
|
|
|
type ProjectInfo =
|
|
{ RelativeProjectPath: string
|
|
AbsoluteProjectPath: string }
|
|
|
|
let fail message =
|
|
raise (UserError message)
|
|
|
|
let runProcess (workingDirectory: string) (exe: string) (args: string list) =
|
|
let psi = ProcessStartInfo()
|
|
psi.FileName <- exe
|
|
psi.WorkingDirectory <- workingDirectory
|
|
psi.RedirectStandardOutput <- false
|
|
psi.RedirectStandardError <- false
|
|
psi.UseShellExecute <- false
|
|
|
|
for arg in args do
|
|
psi.ArgumentList.Add arg
|
|
|
|
use proc = new Process()
|
|
proc.StartInfo <- psi
|
|
|
|
if not (proc.Start()) then
|
|
failwithf "Failed to start %s" exe
|
|
|
|
proc.WaitForExit()
|
|
proc.ExitCode
|
|
|
|
let captureProcess (workingDirectory: string) (exe: string) (args: string list) =
|
|
let psi = ProcessStartInfo()
|
|
psi.FileName <- exe
|
|
psi.WorkingDirectory <- workingDirectory
|
|
psi.RedirectStandardOutput <- true
|
|
psi.RedirectStandardError <- true
|
|
psi.UseShellExecute <- false
|
|
|
|
for arg in args do
|
|
psi.ArgumentList.Add arg
|
|
|
|
use proc = new Process()
|
|
proc.StartInfo <- psi
|
|
|
|
if not (proc.Start()) then
|
|
failwithf "Failed to start %s" exe
|
|
|
|
let stdout = proc.StandardOutput.ReadToEnd()
|
|
let stderr = proc.StandardError.ReadToEnd()
|
|
proc.WaitForExit()
|
|
proc.ExitCode, stdout, stderr
|
|
|
|
let repoRoot =
|
|
let exitCode, stdout, stderr =
|
|
captureProcess Environment.CurrentDirectory "git" [ "rev-parse"; "--show-toplevel" ]
|
|
|
|
if exitCode <> 0 then
|
|
fail stderr
|
|
|
|
stdout.Trim()
|
|
|
|
let parseArgs (args: string list) =
|
|
let usage () =
|
|
fail "Usage: mutannot <path/to/project.fsproj> [--configuration Debug|Release] [--build-arg <value> ...] [--no-build] [--list | --show <id> | --run [id...]]"
|
|
|
|
let rec loop configuration projectPath buildArgs noBuild remaining =
|
|
match remaining with
|
|
| [] ->
|
|
{ Configuration = configuration
|
|
ProjectPath = projectPath
|
|
BuildArgs = List.rev buildArgs
|
|
NoBuild = noBuild
|
|
Command = Run [] }
|
|
| "--configuration" :: value :: tail -> loop value projectPath buildArgs noBuild tail
|
|
| "--build-arg" :: value :: tail -> loop configuration projectPath (value :: buildArgs) noBuild tail
|
|
| "--no-build" :: tail -> loop configuration projectPath buildArgs true tail
|
|
| "--list" :: tail when tail.IsEmpty ->
|
|
{ Configuration = configuration
|
|
ProjectPath = projectPath
|
|
BuildArgs = List.rev buildArgs
|
|
NoBuild = noBuild
|
|
Command = List }
|
|
| "--show" :: id :: tail when tail.IsEmpty ->
|
|
{ Configuration = configuration
|
|
ProjectPath = projectPath
|
|
BuildArgs = List.rev buildArgs
|
|
NoBuild = noBuild
|
|
Command = Show id }
|
|
| "--run" :: tail ->
|
|
{ Configuration = configuration
|
|
ProjectPath = projectPath
|
|
BuildArgs = List.rev buildArgs
|
|
NoBuild = noBuild
|
|
Command = Run tail }
|
|
| value :: tail when not (value.StartsWith "--") ->
|
|
{ Configuration = configuration
|
|
ProjectPath = projectPath
|
|
BuildArgs = List.rev buildArgs
|
|
NoBuild = noBuild
|
|
Command = Run (value :: tail) }
|
|
| _ -> usage ()
|
|
|
|
match args with
|
|
| projectPath :: tail when not (projectPath.StartsWith "--") -> loop "Debug" projectPath [] false tail
|
|
| _ -> usage ()
|
|
|
|
let ensureWithinRepo (path: string) =
|
|
let relativePath = Path.GetRelativePath(repoRoot, path)
|
|
|
|
if relativePath = ".." || relativePath.StartsWith($"..{Path.DirectorySeparatorChar}") then
|
|
fail $"Project path must be inside the repository: {path}"
|
|
|
|
relativePath
|
|
|
|
let loadProjectInfo (projectPath: string) =
|
|
let absoluteProjectPath =
|
|
if Path.IsPathRooted projectPath then
|
|
projectPath
|
|
else
|
|
Path.GetFullPath(Path.Combine(Environment.CurrentDirectory, projectPath))
|
|
|
|
if not (File.Exists absoluteProjectPath) then
|
|
fail $"Project file not found: {absoluteProjectPath}"
|
|
|
|
let relativeProjectPath = ensureWithinRepo absoluteProjectPath
|
|
|
|
{ RelativeProjectPath = relativeProjectPath
|
|
AbsoluteProjectPath = absoluteProjectPath }
|
|
|
|
let targetPathForProject (workingDirectory: string) (projectPath: string) (configuration: string) =
|
|
let exitCode, stdout, stderr =
|
|
captureProcess
|
|
workingDirectory
|
|
"dotnet"
|
|
[ "msbuild"
|
|
projectPath
|
|
"--getProperty:TargetPath"
|
|
$"-property:Configuration={configuration}" ]
|
|
|
|
if exitCode <> 0 then
|
|
fail stderr
|
|
|
|
let targetPath = stdout.Trim()
|
|
|
|
if String.IsNullOrWhiteSpace targetPath then
|
|
fail $"MSBuild did not return a TargetPath for {projectPath}."
|
|
|
|
targetPath
|
|
|
|
let buildArgs configuration extraArgs projectPath =
|
|
[ "build"; projectPath; "--configuration"; configuration; "--nologo" ] @ extraArgs
|
|
|
|
let ensureBuilt options project assemblyPath =
|
|
if not options.NoBuild then
|
|
let exitCode = runProcess repoRoot "dotnet" (buildArgs options.Configuration options.BuildArgs project.RelativeProjectPath)
|
|
|
|
if exitCode <> 0 then
|
|
fail "dotnet build failed."
|
|
|
|
if not (File.Exists assemblyPath) then
|
|
fail $"Compiled test assembly not found at {assemblyPath}."
|
|
|
|
let installAssemblyResolver (assemblyPath: string) =
|
|
let assemblyDir = Path.GetDirectoryName assemblyPath
|
|
|
|
AppDomain.CurrentDomain.add_AssemblyResolve (
|
|
ResolveEventHandler(fun _ args ->
|
|
let name = AssemblyName(args.Name).Name + ".dll"
|
|
let candidate = Path.Combine(assemblyDir, name)
|
|
|
|
if File.Exists candidate then
|
|
Assembly.LoadFrom candidate
|
|
else
|
|
null)
|
|
)
|
|
|
|
let mutationCases options project assemblyPath =
|
|
ensureBuilt options project assemblyPath
|
|
installAssemblyResolver assemblyPath
|
|
|
|
let asm = Assembly.LoadFrom assemblyPath
|
|
|
|
asm.GetTypes()
|
|
|> Array.collect (fun t ->
|
|
t.GetMethods(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance)
|
|
|> Array.collect (fun m ->
|
|
m.GetCustomAttributesData()
|
|
|> Seq.filter (fun attr -> attr.AttributeType.FullName = "Mutannot.MutationCaseAttribute")
|
|
|> Seq.map (fun attr ->
|
|
let args = attr.ConstructorArguments
|
|
|
|
if args.Count <> 5 then
|
|
failwithf "Unexpected MutationCaseAttribute shape on %s.%s" t.FullName m.Name
|
|
|
|
let declaringType =
|
|
match t.FullName with
|
|
| null -> t.Name
|
|
| name -> name
|
|
|
|
{ Id = unbox<string> args[0].Value
|
|
File = unbox<string> args[1].Value
|
|
Line = unbox<int> args[2].Value
|
|
Find = unbox<string> args[3].Value
|
|
Replace = unbox<string> args[4].Value
|
|
TestName = m.Name
|
|
DeclaringType = declaringType })
|
|
|> Seq.toArray))
|
|
|> Array.sortBy (fun mutation -> mutation.Id)
|
|
|
|
let findMutation id mutations =
|
|
mutations
|
|
|> Array.tryFind (fun mutation -> mutation.Id = id)
|
|
|> Option.defaultWith (fun () -> fail $"Unknown mutation id: {id}")
|
|
|
|
let lineSpan (filePath: string) (text: string) (lineNumber: int) =
|
|
if lineNumber < 1 then
|
|
fail $"Line number must be positive: {lineNumber}"
|
|
|
|
let mutable currentLine = 1
|
|
let mutable lineStart = 0
|
|
let mutable index = 0
|
|
|
|
while index < text.Length && currentLine < lineNumber do
|
|
if text[index] = '\n' then
|
|
currentLine <- currentLine + 1
|
|
lineStart <- index + 1
|
|
|
|
index <- index + 1
|
|
|
|
if currentLine <> lineNumber then
|
|
fail $"Line {lineNumber} does not exist in {filePath}"
|
|
|
|
let mutable lineEnd = lineStart
|
|
|
|
while lineEnd < text.Length && text[lineEnd] <> '\n' && text[lineEnd] <> '\r' do
|
|
lineEnd <- lineEnd + 1
|
|
|
|
lineStart, lineEnd
|
|
|
|
let replaceOccurrenceOnLine (mutation: MutationCase) (text: string) =
|
|
let lineStart, lineEnd = lineSpan mutation.File text mutation.Line
|
|
let lineText = text.Substring(lineStart, lineEnd - lineStart)
|
|
let lineOffset = lineText.IndexOf(mutation.Find, StringComparison.Ordinal)
|
|
|
|
if lineOffset < 0 then
|
|
fail $"Line {mutation.Line} in {mutation.File} does not contain '{mutation.Find}'."
|
|
|
|
let absoluteOffset = lineStart + lineOffset
|
|
text.Remove(absoluteOffset, mutation.Find.Length).Insert(absoluteOffset, mutation.Replace)
|
|
|
|
let printMutation mutation =
|
|
printfn "id: %s" mutation.Id
|
|
printfn "test: %s.%s" mutation.DeclaringType mutation.TestName
|
|
printfn "file: %s:%d" mutation.File mutation.Line
|
|
printfn "find: %s" mutation.Find
|
|
printfn "replace: %s" mutation.Replace
|
|
|
|
let splitNullSeparated (text: string) =
|
|
text.Split('\000', StringSplitOptions.RemoveEmptyEntries) |> Array.toList
|
|
|
|
let repoRelativePath (path: string) =
|
|
path.Replace('/', Path.DirectorySeparatorChar)
|
|
|
|
let listUntrackedFiles () =
|
|
let exitCode, stdout, stderr =
|
|
captureProcess repoRoot "git" [ "ls-files"; "--others"; "--exclude-standard"; "-z" ]
|
|
|
|
if exitCode <> 0 then
|
|
fail stderr
|
|
|
|
splitNullSeparated stdout
|
|
|
|
let copyFileIntoWorktree (repoRoot: string) (worktreePath: string) (relativePath: string) =
|
|
let sourcePath = Path.Combine(repoRoot, repoRelativePath relativePath)
|
|
let destinationPath = Path.Combine(worktreePath, repoRelativePath relativePath)
|
|
let destinationDir = Path.GetDirectoryName destinationPath
|
|
|
|
if not (String.IsNullOrEmpty destinationDir) then
|
|
Directory.CreateDirectory(destinationDir) |> ignore
|
|
|
|
File.Copy(sourcePath, destinationPath, true)
|
|
|
|
let cleanup (tempRoot: string) (worktreePath: string) =
|
|
if Directory.Exists worktreePath then
|
|
let _ = captureProcess repoRoot "git" [ "worktree"; "remove"; "--force"; worktreePath ]
|
|
()
|
|
|
|
if Directory.Exists tempRoot then
|
|
Directory.Delete(tempRoot, true)
|
|
|
|
let createWorktree (patchPath: string) (worktreePath: string) =
|
|
let tempRoot = Path.GetDirectoryName patchPath
|
|
Directory.CreateDirectory(tempRoot) |> ignore
|
|
|
|
let untrackedFiles = listUntrackedFiles ()
|
|
let exitCode, diffText, stderr = captureProcess repoRoot "git" [ "diff"; "--binary"; "HEAD" ]
|
|
|
|
if exitCode <> 0 then
|
|
fail stderr
|
|
|
|
File.WriteAllText(patchPath, diffText)
|
|
|
|
let exitCode2, stdout2, stderr2 = captureProcess repoRoot "git" [ "rev-parse"; "HEAD" ]
|
|
|
|
if exitCode2 <> 0 then
|
|
fail stderr2
|
|
|
|
let baseRev = stdout2.Trim()
|
|
let exitCode3, _, stderr3 = captureProcess repoRoot "git" [ "worktree"; "add"; "--detach"; worktreePath; baseRev ]
|
|
|
|
if exitCode3 <> 0 then
|
|
fail stderr3
|
|
|
|
if FileInfo(patchPath).Length > 0L then
|
|
let exitCode4, _, stderr4 = captureProcess worktreePath "git" [ "apply"; patchPath ]
|
|
|
|
if exitCode4 <> 0 then
|
|
fail stderr4
|
|
|
|
for relativePath in untrackedFiles do
|
|
copyFileIntoWorktree repoRoot worktreePath relativePath
|
|
|
|
let fullyQualifiedTestName mutation =
|
|
let declaringType = mutation.DeclaringType.Replace('+', '.')
|
|
$"{declaringType}.{mutation.TestName}"
|
|
|
|
let testFilter mutation =
|
|
$"FullyQualifiedName={fullyQualifiedTestName mutation}"
|
|
|
|
let runMutation options project worktreePath mutation =
|
|
let targetFile = Path.Combine(worktreePath, mutation.File.Replace('/', Path.DirectorySeparatorChar))
|
|
|
|
if not (File.Exists targetFile) then
|
|
fail $"Target file does not exist in worktree: {targetFile}"
|
|
|
|
let originalText = File.ReadAllText targetFile
|
|
let mutatedText = replaceOccurrenceOnLine mutation originalText
|
|
File.WriteAllText(targetFile, mutatedText)
|
|
|
|
printfn "==> %s: %s" mutation.Id mutation.TestName
|
|
|
|
let buildExitCode =
|
|
runProcess worktreePath "dotnet" (buildArgs options.Configuration options.BuildArgs project.RelativeProjectPath)
|
|
|
|
let outcome =
|
|
if buildExitCode <> 0 then
|
|
printfn "BUILD FAILED %s" mutation.Id
|
|
BuildFailed
|
|
else
|
|
let testExitCode =
|
|
runProcess
|
|
worktreePath
|
|
"dotnet"
|
|
[ "test"
|
|
project.RelativeProjectPath
|
|
"--configuration"
|
|
options.Configuration
|
|
"--filter"
|
|
testFilter mutation
|
|
"--no-build"
|
|
"--nologo" ]
|
|
|
|
if testExitCode = 0 then
|
|
printfn "SURVIVED %s" mutation.Id
|
|
Survived
|
|
else
|
|
printfn "KILLED %s" mutation.Id
|
|
Killed
|
|
|
|
File.WriteAllText(targetFile, originalText)
|
|
outcome
|
|
|
|
[<EntryPoint>]
|
|
let main argv =
|
|
try
|
|
let options = parseArgs (argv |> Array.toList)
|
|
let project = loadProjectInfo options.ProjectPath
|
|
let assemblyPath = targetPathForProject repoRoot project.AbsoluteProjectPath options.Configuration
|
|
let mutations = mutationCases options project assemblyPath
|
|
|
|
if Array.isEmpty mutations then
|
|
fail "No mutation cases were discovered in the test assembly."
|
|
|
|
match options.Command with
|
|
| List ->
|
|
mutations
|
|
|> Array.iter (fun mutation ->
|
|
printfn "%s\t%s\t%s:%d" mutation.Id mutation.TestName mutation.File mutation.Line)
|
|
|
|
0
|
|
| Show id ->
|
|
let mutation = findMutation id mutations
|
|
printMutation mutation
|
|
0
|
|
| Run ids ->
|
|
let requested =
|
|
match ids with
|
|
| [] -> mutations |> Array.toList
|
|
| _ -> ids |> List.map (fun id -> findMutation id mutations)
|
|
|
|
let tempRoot = Path.Combine(Path.GetTempPath(), $"fscheck-mutants.{Guid.NewGuid():N}")
|
|
let worktreePath = Path.Combine(tempRoot, "worktree")
|
|
let patchPath = Path.Combine(tempRoot, "current.patch")
|
|
|
|
try
|
|
createWorktree patchPath worktreePath
|
|
|
|
let outcomes =
|
|
requested |> List.map (runMutation options project worktreePath)
|
|
|
|
let survivors = outcomes |> List.filter ((=) Survived) |> List.length
|
|
let buildFailures = outcomes |> List.filter ((=) BuildFailed) |> List.length
|
|
|
|
if survivors = 0 && buildFailures = 0 then
|
|
printfn "All requested mutants were killed."
|
|
0
|
|
else
|
|
fail $"{survivors} mutant(s) survived. {buildFailures} mutant(s) failed to build."
|
|
finally
|
|
cleanup tempRoot worktreePath
|
|
with
|
|
| UserError message ->
|
|
eprintfn "%s" message
|
|
1
|