Platforms to show: All Mac Windows Linux Cross-Platform
/Util/BugreporterKit/BugReporter
You find this example project in your Plugins Download as a Xojo project file within the examples folder: /Util/BugreporterKit/BugReporter
This example is the version from Sat, 18th Aug 2023.
Project "BugReporter.xojo_binary_project"
Class App Inherits Application
Const kEditClear = "&Löschen"
Const kFileQuit = "Beenden"
Const kFileQuitShortcut = ""
EventHandler Sub Open()
// License code registration could be done here
End EventHandler
EventHandler Function UnhandledException(error As RuntimeException) As Boolean
return BugReporter.UnhandledException(error)
End EventHandler
End Class
Class TestWindow Inherits Window
Control ReportButton Inherits PushButton
ControlInstance ReportButton Inherits PushButton
EventHandler Sub Action()
BugReporter.showBugReport
End EventHandler
End Control
Control FeatureRequestButton Inherits PushButton
ControlInstance FeatureRequestButton Inherits PushButton
EventHandler Sub Action()
BugReporter.showFeatureRequest
End EventHandler
End Control
Control CrashUglyButton Inherits PushButton
ControlInstance CrashUglyButton Inherits PushButton
EventHandler Sub Action()
CrashUglyMBS
End EventHandler
End Control
Control PushButton4 Inherits PushButton
ControlInstance PushButton4 Inherits PushButton
EventHandler Sub Action()
CrashNiceMBS
End EventHandler
End Control
Control PushButton5 Inherits PushButton
ControlInstance PushButton5 Inherits PushButton
EventHandler Sub Action()
dim w as Dictionary
w.Clear
End EventHandler
End Control
Control PushButton6 Inherits PushButton
ControlInstance PushButton6 Inherits PushButton
EventHandler Sub Action()
dim a(3) as integer
dim n as integer
n=10
a(n)=5
End EventHandler
End Control
Control PushButton7 Inherits PushButton
ControlInstance PushButton7 Inherits PushButton
EventHandler Sub Action()
dim r as new RuntimeException
r.Message="Just a test exception"
Raise r
End EventHandler
End Control
Control StaticText1 Inherits Label
ControlInstance StaticText1 Inherits Label
End Control
Control StaticText2 Inherits Label
ControlInstance StaticText2 Inherits Label
End Control
Control SetCompanyButton Inherits PushButton
ControlInstance SetCompanyButton Inherits PushButton
EventHandler Sub Action()
BugReporter.SetCompanyName "BugCreator, Inc", true
BugReporter.SetEmailAddress "test@test.test", true
BugReporter.SetCustomData "Just some custom data"
End EventHandler
End Control
Control PushButton9 Inherits PushButton
ControlInstance PushButton9 Inherits PushButton
EventHandler Sub Action()
#if TargetMacos then
dim n as new NSAttributedStringMBS
dim w as new NSColorMBS(&cFF0000)
// Swap handles
n.Handle=w.Handle
w.Handle=0
// call a method on the NSButton class which is from the NSAttributedString class -> Error!
dim e as string = n.htmlString
MsgBox e
#else
MsgBox "This exception is only working on Mac OS X."
#endif
End EventHandler
End Control
Control PushButton10 Inherits PushButton
ControlInstance PushButton10 Inherits PushButton
EventHandler Sub Action()
dim g as new DirectShowGUIDMBS
call g.byte(122)
End EventHandler
End Control
Control PushButton11 Inherits PushButton
ControlInstance PushButton11 Inherits PushButton
EventHandler Sub Action()
// we use a lot of memory with arrays and REAL Studio runtime crashes with an unhandled C++ exception
dim sa(-1) as string
dim ma(-1) as MemoryBlock
const m = 30000000
redim sa(m)
redim ma(m)
dim t as string = "Hello World. This is a text."
for i as integer = 1 to M
dim x as MemoryBlock = t
t = x
sa.Append t
ma.append x
next
MsgBox "OK."+EndOfLine+EndOfLine+"You can now close window to see if memory cleanup works."
End EventHandler
End Control
Control PushButton12 Inherits PushButton
ControlInstance PushButton12 Inherits PushButton
EventHandler Sub Action()
SignalHandlerMBS.alarm(3)
End EventHandler
End Control
Control StaticText3 Inherits Label
ControlInstance StaticText3 Inherits Label
End Control
Control StaticText4 Inherits Label
ControlInstance StaticText4 Inherits Label
End Control
Control PushButton13 Inherits PushButton
ControlInstance PushButton13 Inherits PushButton
EventHandler Sub Action()
Thread1.run
End EventHandler
End Control
Control Thread1 Inherits Thread
ControlInstance Thread1 Inherits Thread
EventHandler Sub Run()
// raise exception on thread
dim r as new RuntimeException
r.Message="Just a test exception"
Raise r
End EventHandler
End Control
EventHandler Sub Open()
// you can call this method to check for old crash reports to be sent.
BugReporter.CheckForCrashes
BugReporter.FixLinuxButtons self
End EventHandler
End Class
MenuBar MenuBar1
MenuItem FileMenu = "&Ablage"
MenuItem FileQuit = "#App.kFileQuit"
MenuItem EditMenu = "&Bearbeiten"
MenuItem EditUndo = "&Rückgängig"
MenuItem UntitledMenu1 = "-"
MenuItem EditCut = "&Ausschneiden"
MenuItem EditCopy = "&Kopieren"
MenuItem EditPaste = "&Einfügen"
MenuItem EditClear = "#App.kEditClear"
MenuItem UntitledMenu0 = "-"
MenuItem EditSelectAll = "&Alles auswählen"
End MenuBar
MyFileTypes
Filetype Text
End MyFileTypes
Class MyGlobalExceptionHandlerMBS Inherits GlobalExceptionHandlerMBS
EventHandler Sub GotException()
#Pragma StackOverflowChecking false
dim BackTraceLines() as string
#if mbs.BuildNumber>17662 and not TargetWin32 then // new in 13.0 plugins
BackTraceLines = BacktraceMBS
#endif
#if TargetConsole
BugReporterConsole.ShowExceptionReporter "C++ exception", BackTraceLines
#else
BugReporter.ShowExceptionReporter "C++ exception", BackTraceLines
#endif
// quit now without cleaning up the RB runtime which may crash again
ExitMBS 1
End EventHandler
End Class
Module BugReporterConfiguration
Const AllowContinueAfterException = true
Const AutoSendBugreportAfterDelay = 60
Const ReportNetworkInterfaces = true
Const TextFileTypeName = "text"
Const kScriptURL = "http://www.monkeybreadsoftware.de/cgi-bin/bugreporter.php"
Const kSupportEmail = "support@monkeybreadsoftware.de"
Const kUseAddressbookViaMBS = false
Const kUseAddressbookViaRS = false
Protected Function QueryApplicationState() As string
#Pragma StackOverflowChecking false
// return here any custom variables you may need for your bug report in one string
Return "Just a test for the application state"
End Function
End Module
Class BugReporter Inherits Window
Const kBugReporterTitle = "BugReporter"
Const kCancel = "Cancel"
Const kClassification = "Classification:"
Const kClassificationApplicationFreezed = "Application freezed"
Const kClassificationBug = "Bug"
Const kClassificationCrash = "Crash"
Const kClassificationDataLoss = "Data loss"
Const kClassificationFeatureOrder = "Feature Order"
Const kClassificationFeatureRequest = "Feature Request"
Const kClassificationImportantBug = "Important bug"
Const kClassificationNotSet = "Not set"
Const kClassificationPerformance = "Performance"
Const kClassificationSecurityProblem = "Security problem"
Const kClassificationUsability = "Usability"
Const kClassificationUserInterface = "User interface"
Const kClassificationWish = "Wish"
Const kCommentLabel = "Comments:"
Const kCompanyLabel = "Your Company:"
Const kComputer = "Your Computer:"
Const kContinueExplanation = "If you continue the application may not work correctly as the current state may be undefined."
Const kContinueLabel = "Continue"
Const kContinueQuestion = "The application had an error. Do you want to quit or do you want to continue?"
Const kDescription = "Description:"
Const kEmailLabel = "Your email address:"
Const kFailedToCreateTextFile = "Failed to create text file."
Const kFeatureRequest = "Your feature request:"
Const kFileSaved = "The file was saved. Please email it to %. Thank you."
Const kInternetTrouble = "There is a problem with the internet connection. You can now save the report and send it manually by email."
Const kNameLabel = "Your name:"
Const kProblemDescription = "Problem Description:"
Const kProduct = "Product:"
Const kReasonBugReport = "Please enter your bug report in this form:"
Const kReasonCrash = "This application crashed recently. You can send a bug report to us so we can fix it:"
Const kReasonException = "This application has produced an error. Please fill this form so we can locate the bug and fix it: "
Const kReasonFeature = "Please enter your feature request here:"
Const kReproduce = "Steps to reproduce:"
Const kSave = "Save..."
Const kSend = "Send"
Const kShowdetails = "Show details"
Const kSubject = "Short description:"
Const kTabPanelApplicationDetails = "Application details"
Const kTabPanelDescription = "Description"
Const kTabPanelYourDetails = "Your details"
Const kquitLabel = "Quit"
Control Status Inherits Label
ControlInstance Status Inherits Label
End Control
Control SendButton Inherits PushButton
ControlInstance SendButton Inherits PushButton
EventHandler Sub Action()
// press alt key to save
if Keyboard.AsyncAltKey then
DoSave
elseif HaveInternet then
DoSend
else
DoSave
end if
End EventHandler
End Control
Control CancelButton Inherits PushButton
ControlInstance CancelButton Inherits PushButton
EventHandler Sub Action()
close
End EventHandler
End Control
Control Timer1 Inherits Timer
ControlInstance Timer1 Inherits Timer
EventHandler Sub Action()
// press alt key to save
if Keyboard.AsyncAltKey then
SendButton.Caption=kSave
else
SendButton.Caption=kSend
end if
End EventHandler
End Control
Control sock Inherits HTTPSocket
ControlInstance sock Inherits HTTPSocket
EventHandler Sub Connected()
if status<>nil then
status.text="Connected"
end if
End EventHandler
EventHandler Sub Error(code as integer)
if code=102 then
// ignore
elseif code=103 then
HaveInternet=false
MsgBox kInternetTrouble
DoSave
elseif status<>nil then
status.text="Error: "+str(code)
end if
End EventHandler
EventHandler Sub PageReceived(url as string, httpStatus as integer, headers as internetHeaders, content as string)
#pragma Unused URL
#pragma Unused headers
#pragma Unused content
if status<>nil then
status.text="Page Received: "+str(httpStatus)
end if
if left(content,2)="OK" then
close
Return
end if
End EventHandler
End Control
Control AutoSendTimer Inherits Timer
ControlInstance AutoSendTimer Inherits Timer
EventHandler Sub Action()
if SendButton.Enabled then
SendButton.Push
end if
End EventHandler
End Control
Control Tab Inherits TabPanel
ControlInstance Tab Inherits TabPanel
EventHandler Sub Change()
AutoSendTimer.mode=AutoSendTimer.ModeOff
End EventHandler
EventHandler Sub Open()
me.Caption(0)=kTabPanelDescription
me.Caption(1)=kTabPanelYourDetails
'me.Caption(2)=kTabPanelApplicationDetails
End EventHandler
End Control
Control iDescription Inherits TextArea
ControlInstance iDescription Inherits TextArea
EventHandler Sub Open()
#if DebugBuild
me.text="Sample description"
#endif
End EventHandler
EventHandler Sub TextChange()
AutoSendTimer.mode=AutoSendTimer.ModeOff
End EventHandler
End Control
Control StaticText4 Inherits Label
ControlInstance StaticText4 Inherits Label
End Control
Control StepLabel Inherits Label
ControlInstance StepLabel Inherits Label
End Control
Control iSteps Inherits TextArea
ControlInstance iSteps Inherits TextArea
EventHandler Sub Open()
#if DebugBuild
me.text="Sample steps"
#endif
End EventHandler
EventHandler Sub TextChange()
AutoSendTimer.mode=AutoSendTimer.ModeOff
End EventHandler
End Control
Control Reason Inherits Label
ControlInstance Reason Inherits Label
End Control
Control iName Inherits TextField
ControlInstance iName Inherits TextField
EventHandler Sub Open()
me.text = SystemInformationMBS.Username
End EventHandler
End Control
Control LabelName Inherits Label
ControlInstance LabelName Inherits Label
End Control
Control iCompany Inherits TextField
ControlInstance iCompany Inherits TextField
EventHandler Sub Open()
#if DebugBuild
me.text="Sample Company"
#endif
me.text=CompanyName
me.ReadOnly=CompanyNameReadOnly
End EventHandler
End Control
Control LabelCompany Inherits Label
ControlInstance LabelCompany Inherits Label
End Control
Control iEmail Inherits TextField
ControlInstance iEmail Inherits TextField
EventHandler Sub Open()
me.text=EmailAddress
me.ReadOnly=EmailAddressReadonly
if me.text="" then
// Mac OS X 10.8 shows a dialog to ask if Addressbook access is okay.
// We try to avoid the dialog
#if BugReporterConfiguration.kUseAddressbookViaMBS
#if TargetMacOS then
if ABAddressBookMBS.GotSharedAddressbook or not SystemInformationMBS.isMountainLion then
dim a as ABAddressBookMBS = ABAddressBookMBS.sharedAddressbook
dim p as ABPersonMBS = a.owner
dim m as ABMultiValueMBS = p.valueForProperty(a.kABEmailProperty)
if m<>nil then
dim v as Variant = m.valueForIdentifier(m.primaryIdentifier)
me.text = v
end if
end if
#endif
#elseif BugReporterConfiguration.kUseAddressbookViaRS
if not SystemInformationMBS.isMountainLion then
dim a as AddressBook = System.AddressBook
dim p as AddressBookContact = a.CurrentUser
me.text=p.EmailAddresses.Operator_Convert
end if
#endif
end if
Exception
End EventHandler
End Control
Control LabelEmail Inherits Label
ControlInstance LabelEmail Inherits Label
End Control
Control iComputer Inherits TextField
ControlInstance iComputer Inherits TextField
EventHandler Sub Open()
me.text=SystemInformationMBS.ComputerName
End EventHandler
End Control
Control LabelComputer Inherits Label
ControlInstance LabelComputer Inherits Label
End Control
Control iProduct Inherits TextField
ControlInstance iProduct Inherits TextField
EventHandler Sub Open()
if app<>nil then
me.text=DefineEncoding(app.LongVersion,Encodings.UTF8)
end if
End EventHandler
End Control
Control LabelProduct Inherits Label
ControlInstance LabelProduct Inherits Label
End Control
Control iClassification Inherits PopupMenu
ControlInstance iClassification Inherits PopupMenu
End Control
Control LabelClassification Inherits Label
ControlInstance LabelClassification Inherits Label
End Control
Control LabelComment Inherits Label
ControlInstance LabelComment Inherits Label
End Control
Control iComment Inherits TextArea
ControlInstance iComment Inherits TextArea
End Control
EventHandler Sub Open()
// if AutoSendBugreportAfterDelay is activated, we send the bug report after time passed.
// this timer is deactivated if user does something
if BugReporterConfiguration.AutoSendBugreportAfterDelay>0 then
AutoSendTimer.Period=1000*BugReporterConfiguration.AutoSendBugreportAfterDelay
AutoSendTimer.Mode=AutoSendTimer.ModeSingle
end if
BugReporter.FixLinuxButtons self
#if TargetLinux // workaround a bug on Linux
Width = 600
Height = 500
#endif
End EventHandler
Shared Sub CheckForCrashes()
#Pragma StackOverflowChecking false
// call when your application has been launch
// searches for existing crash reports
#if TargetMachO then
dim file as FolderItem
dim folder as FolderItem
dim i,c as integer
// with MBS Plugins:
folder=LogsFolderMBS(0)
// without:
'folder=SpecialFolder.Library
'if folder=nil then Return
'folder=folder.Child("Logs")
if folder=nil then Return
folder=folder.Child("CrashReporter")
if folder=nil then Return
if app = nil then Return // app half quit already
dim name as string = app.ApplicationNameMBS
dim names(-1) as string
dim files(-1) as FolderItem
c=folder.Count
for i=1 to c
file=folder.TrueItem(i)
if file<>Nil and file.Visible and file.Directory=False and left(file.Name,len(name))=name then
names.Append file.name
files.append file
end if
next
if UBound(names)<0 then Return
names.SortWith files
dim w as new BugReporter
w.SetClassificationBugReport
w.Reason.text=kReasonCrash
w.SetDetails nil,Files(UBound(files))
w.CheckSending
w.ShowModal
#endif
End Sub
Private Sub CheckSending()
#Pragma StackOverflowChecking false
// do we have internet?
// if we have a DNS server and we find 3 of 5 domains, we should be online
dim n as integer
dim ip as string
ip=System.Network.LookupIPAddress("www.google.com")
if len(ip)>0 then n=n+1
ip=System.Network.LookupIPAddress("www.apple.com")
if len(ip)>0 then n=n+1
ip=System.Network.LookupIPAddress("www.microsoft.com")
if len(ip)>0 then n=n+1
ip=System.Network.LookupIPAddress("www.monkeybreadsoftware.de")
if len(ip)>0 then n=n+1
ip=System.Network.LookupIPAddress("www.wikipedia.org")
if len(ip)>0 then n=n+1
// if DNS is okay, we certainly have internet access
if n>=3 then
HaveInternet=true
SendButton.Caption=kSend
else
SendButton.Caption=kSave
end if
End Sub
Private Function DateString(d as date) As string
#Pragma StackOverflowChecking false
// returns a date as a sql string
if d=nil then
Return "n/a"
else
Return d.SQLDateTime
end if
End Function
Private Sub DisableSteps()
#Pragma StackOverflowChecking false
// Remove the steps TextField and resize the description TextField
StepLabel.Visible=False
iSteps.Visible=False
iSteps.text="n/a"
iDescription.Height=269
End Sub
Private Sub DoSave()
#Pragma StackOverflowChecking false
dim t as TextOutputStream
dim f as FolderItem
f=GetSaveFolderItem(BugReporterConfiguration.TextFileTypeName,"Report.txt")
if f=nil then Return
try
t = TextOutputStream.Create(f)
catch i as IOException
MsgBox kFailedToCreateTextFile
Return
end try
dim lines(-1) as string
dim i,c as integer
lines=MakeReport
c=UBound(lines)
for i=0 to c
t.WriteLine lines(i)
next
t.Close
MsgBox ReplaceAll(kFileSaved, "%", BugReporterConfiguration.kSupportEmail)
close
End Sub
Private Sub DoSend()
#Pragma StackOverflowChecking false
dim lines(-1) as string
dim s as string
lines=MakeReport
s=Join(lines, EndOfLine)
dim dic as new Dictionary
dic.Value("text")=s
dic.Value("reason")=ReasonText
// if you have udpater engine, you can support proxies here:
' UpdaterEngine.SetSocketProxy(sock)
sock.SetRequestContent "",""
sock.SetFormData dic
sock.Post(BugReporterConfiguration.kScriptURL)
End Sub
Shared Sub FixLinuxButtons(w as window)
#pragma Unused w
#Pragma StackOverflowChecking false
#if TargetLinux then
dim u as integer = w.controlcount-1
for i as integer = 0 to u
dim o as variant = w.Control(i)
if o isa PushButton then
dim p as PushButton = o
p.height = 28
end if
next
#endif
End Sub
Private Shared Function FormatMemory(d as Double) As string
#Pragma StackOverflowChecking false
if d<1500 then
Return Format(d, "-0")+" Bytes"
end if
d = d / 1024.0
if d<1500 then
Return Format(d, "-0")+" KB"
end if
d = d / 1024.0
Return Format(d, "-0")+" MB"
End Function
Private Shared Function GetExceptionName(error as RuntimeException) As string
#Pragma StackOverflowChecking false
Return GetObjectClassName(error)
End Function
Private Shared Function GetObjectClassName(o as Object) As string
#Pragma StackOverflowChecking false
dim t as Introspection.TypeInfo = Introspection.GetType(o)
if t<>Nil then
Return t.FullName
end if
End Function
Private Function MakeReport() As string()
#Pragma StackOverflowChecking false
dim lines(-1) as string
dim i,c as integer
dim b as string
dim ilines(-1) as string
lines.Append "Reason: "+Reason.text
lines.Append "Name: "+iName.text
lines.Append "Company: "+iCompany.text
lines.Append "Email: "+iEmail.text
lines.Append "Computer: "+iComputer.text
lines.Append "Product: "+iProduct.text
lines.Append "Classification: "+iClassification.Text
lines.Append ""
// Description
lines.Append "Description:"
b=ReplaceLineEndings(iDescription.text,EndOfLine)
ilines=split(b,EndOfLine)
c=UBound(ilines)
for i=0 to c
lines.Append ilines(i)
next
lines.Append ""
// Steps
lines.Append "Steps:"
b=ReplaceLineEndings(iSteps.text,EndOfLine)
ilines=split(b,EndOfLine)
c=UBound(ilines)
for i=0 to c
lines.Append ilines(i)
next
lines.Append ""
// Comment
lines.Append "Comment:"
b=ReplaceLineEndings(iComment.text,EndOfLine)
ilines=split(b,EndOfLine)
c=UBound(ilines)
for i=0 to c
lines.Append ilines(i)
next
lines.Append ""
// Details
lines.Append "Details:"
b=ReplaceLineEndings(iDetails,EndOfLine)
ilines=split(b,EndOfLine)
c=UBound(ilines)
for i=0 to c
lines.Append ilines(i)
next
lines.Append ""
// fix encoding
c=UBound(lines)
for i=0 to c
lines(i)=ConvertEncoding(lines(i),encodings.UTF8)
next
Return lines
End Function
Private Sub SetClassificationBugReport()
#Pragma StackOverflowChecking false
iClassification.AddRow ""
iClassification.AddRow kClassificationNotSet //"not set"
iClassification.AddRow kClassificationCrash //"Crash"
iClassification.AddRow kClassificationApplicationFreezed //"Application froze"
iClassification.AddRow kClassificationDataLoss //"Data loss"
iClassification.AddRow kClassificationSecurityProblem //"Security Problem"
iClassification.AddRow kClassificationPerformance //"Performance"
iClassification.AddRow kClassificationUserInterface //"User Interface"
iClassification.AddRow kClassificationUsability //"Usability"
iClassification.AddRow kClassificationBug //"Bug"
iClassification.AddRow kClassificationImportantBug //"Important Bug"
iClassification.ListIndex=0
End Sub
Private Sub SetClassificationFeatureRequest()
#Pragma StackOverflowChecking false
iClassification.AddRow ""
iClassification.AddRow kClassificationWish //"Wish"
iClassification.AddRow kFeatureRequest //"Feature request"
iClassification.AddRow kClassificationFeatureOrder //"Feature order (will cost money)"
End Sub
Shared Sub SetCompanyName(theCompanyName as string, ReadOnly as Boolean=false)
#Pragma StackOverflowChecking false
CompanyName=theCompanyName
CompanyNameReadOnly=ReadOnly
End Sub
Shared Sub SetCustomData(data as string)
#Pragma StackOverflowChecking false
CustomData=data
End Sub
Private Sub SetDetails(error as RuntimeException=nil, crashreport as FolderItem=nil)
#Pragma StackOverflowChecking False
dim lines(-1) as string
dim n as NetworkInterface
dim s as string
// current date/time
lines.Append log(ReasonText)
lines.Append log
lines.Append log("Current date: "+DateString(new date))
lines.Append log
// about executable file (so you can identify it exactly)
dim e as FolderItem
if app<>Nil then
e = app.ExecutableFile
end if
if e<>nil then
lines.Append log("Executable Name: "+e.Name)
#if RBVersion >= 2013.03 then
lines.Append log("Executable Path: "+e.NativePath)
#else
lines.Append log("Executable Path: "+e.AbsolutePath)
#EndIf
lines.Append log("Executable Size: "+Format(e.Length,"0"))
lines.Append log("Executable Modification Date: "+DateString(e.ModificationDate))
lines.Append log("Executable Creation Date: "+DateString(e.CreationDate))
lines.Append log
end if
// version details:
if app<>nil then
lines.Append log("Version: "+str(app.MajorVersion)+"."+str(app.MinorVersion)+"."+str(app.BugVersion)+"."+str(app.NonReleaseVersion))
lines.Append log("Long Version: "+app.LongVersion)
lines.Append log("Short Version: "+app.ShortVersion)
lines.Append log("Package Info: "+app.PackageInfo)
lines.Append log
end if
// system information:
dim d as Double = Runtime.MemoryUsed
if d<0 then // workaround for older bug
d = d + 2^32
end if
lines.Append log("User name: "+SystemInformationMBS.Username)
lines.Append log("Computer name: "+SystemInformationMBS.Computername)
lines.Append log("OS Name: "+SystemInformationMBS.OSName)
lines.Append log("OS Version: "+SystemInformationMBS.OSVersionString)
lines.Append log("ProcessorCount: "+str(SystemInformationMBS.ProcessorCount))
lines.Append log("CommandLine: "+System.CommandLine)
lines.Append log("PhysicalRAM: "+FormatMemory(SystemInformationMBS.PhysicalRAM))
lines.Append log("Runtime.MemoryUsed: "+FormatMemory(d))
lines.Append log("Runtime.ObjectCount: "+str(Runtime.ObjectCount))
lines.Append log
dim LowMemory as Boolean = false
#if TargetMacOS then // check how much memory is currently in usage by application
Dim dru As DarwinResourceUsageMBS = GetDarwinResourceUsageMBS
dim v as DarwinVMStatisticsMBS = GetDarwinVMStatisticsMBS
dim t as new DarwinTaskInfoMBS
dim Pagesize as Double = v.Pagesize
lines.Append log("Application Resident Size: "+FormatMemory(t.ResidentSize))
lines.Append log("Application Virtual Size: "+FormatMemory(t.VirtualSize))
lines.Append Log("Application Integral Max Resident Size: "+FormatMemory(dru.IntegralMaxResidentSetSize))
lines.Append log("Application Page Ins: "+str(t.PageIns))
lines.Append log("Computer Free Memory: "+FormatMemory(Pagesize*v.FreePages))
lines.Append log("Computer Inactive Memory: "+FormatMemory(Pagesize*v.InactivePages))
lines.Append log("Computer Active Memory: "+FormatMemory(Pagesize*v.ActivePages))
lines.Append log("Computer Wired Memory: "+FormatMemory(Pagesize*v.WiredPages))
lines.Append log("Computer Total Free Memory: "+FormatMemory(Pagesize*(v.InactivePages+v.FreePages)))
lines.Append log("Computer Total Used Memory: "+FormatMemory(Pagesize*(v.ActivePages+v.WiredPages)))
d = dru.IntegralMaxResidentSetSize
if d > 2.0*1024*1024*1024 then
LowMemory = true
end if
#endif
#if TargetWin32 then
dim p as new WindowsProcessMemoryInfoMBS
dim v as new WindowsVMStatisticsMBS
lines.Append log("Available Page File Memory: "+FormatMemory(v.AvailablePageFileMemory))
lines.Append log("Available Physical Memory: "+FormatMemory(v.AvailablePhysicalMemory))
lines.Append log("Available Virtual Memory: "+FormatMemory(v.AvailableVirtualMemory))
lines.Append log("Memoryload: "+Format(v.Memoryload/100,"0%"))
lines.Append log("Total Page File Memory: "+FormatMemory(v.TotalPageFileMemory))
lines.Append log("Total Physical Memory: "+FormatMemory(v.TotalPhysicalMemory))
lines.Append log("Total Virtual Memory: "+FormatMemory(v.TotalVirtualMemory))
lines.Append log("Page Fault Count: "+str(p.PageFaultCount))
lines.Append log("Peak Working Set Size: "+FormatMemory(p.PeakWorkingSetSize))
lines.Append log("Working Set Size: "+FormatMemory(p.WorkingSetSize))
lines.Append log("Quota Peak Paged Pool Usage: "+FormatMemory(p.QuotaPeakPagedPoolUsage))
lines.Append log("Quota Paged Pool Usage: "+FormatMemory(p.QuotaPagedPoolUsage))
lines.Append log("Quota Peak Non Paged Pool Usage: "+FormatMemory(p.QuotaPeakNonPagedPoolUsage))
lines.Append log("Quota Non Paged Pool Usage: "+FormatMemory(p.QuotaNonPagedPoolUsage))
lines.Append log("Pagefile Usage: "+FormatMemory(p.PagefileUsage))
lines.Append log("Peak Pagefile Usage: "+FormatMemory(p.PeakPagefileUsage))
d = p.WorkingSetSize
if d > 1024.0*1024.0*1024.0 then
LowMemory = true
end if
#endif
#if TargetLinux then
dim p as new LinuxSysInfoMBS
if p.Valid then
lines.Append log("Total Memory: "+FormatMemory(p.TotalRam))
lines.Append log("Free Memory: "+FormatMemory(p.FreeRam))
lines.Append log("Number of processes: "+FormatMemory(p.NumberOfProcesses))
lines.Append log("Number of processors: "+FormatMemory(p.NumberOfProcessors))
lines.Append log("UpTime: "+str(p.upTime))
end if
#endif
if LowMemory then
lines.Append log
lines.Append log("This may be a crash due to heavy memory usage!")
end if
lines.Append log
if BugReporterConfiguration.ReportNetworkInterfaces then
lines.Append log("Network Intefaces:")
for i As Integer = 0 to System.NetworkInterfaceCount - 1
n = System.GetNetworkInterface(i)
lines.Append log(n.IPAddress+"/"+n.SubnetMask+", "+n.MACAddress)
next
lines.Append log
end if
// exception details:
if error<>Nil then
dim type as string = GetExceptionName(Error)
lines.Append log("Exception Type: "+type)
'iSubject.text="Unhandled "+type
lines.Append log("Message: "+error.Message)
lines.Append log("Error Number: "+str(error.ErrorNumber))
lines.Append log
lines.Append log("Real Studio Backtrace:")
for each line as string in error.Stack
lines.Append log(line)
next
lines.Append log
End If
// show active windows with focus controls. Last window is frontmost
Dim winCount As Integer = WindowCount
If winCount > 0 Then
Dim u As Integer = winCount-1
lines.Append Log(Str(winCount)+" windows:")
For i As Integer = 0 To u
Dim w As Window = Window(i)
If w <> Nil Then
If w IsA BugReporter Then
// ignore
Elseif w.Visible Then
lines.Append Log("Class: "+Introspection.GetType(w).fullname)
lines.Append Log("Title: "+w.title)
Dim f As RectControl = w.focus
If f <> Nil Then
// control with focus
lines.Append Log("Focus: "+f.name)
End If
lines.Append Log("")
End If
end if
Next
End If
if crashreport<>Nil then
lines.Append "Crashreport: "+crashreport.Name
try
dim ti as TextInputStream = TextInputStream.open(crashreport)
while not ti.eof
s=Ti.ReadLine(encodings.ASCII)
lines.Append s
wend
ti.Close
catch io as IOException
// ignore
end try
crashreport.Delete // so we won't send it again
end if
dim data as string = BugReporterConfiguration.QueryApplicationState
if data<>"" then
lines.Append log(data)
lines.Append log
end if
if CustomData<>"" then
lines.Append log(customdata)
lines.Append log
end if
if UBound(BackTraceLines)>=0 then
lines.Append "System Backtrace:"
for each line as string in BackTraceLines
lines.Append line
next
lines.Append ""
end if
iDetails=Join(lines,EndOfLine)
End Sub
Shared Sub SetEmailAddress(theEmailAddress as string, ReadOnly as Boolean=false)
#Pragma StackOverflowChecking false
EmailAddress=theEmailAddress
EmailAddressReadOnly=ReadOnly
End Sub
Shared Sub ShowExceptionReporter(exceptionname as string, BackTraceLines() as string)
#Pragma StackOverflowChecking false
// shows a bug report dialog for a windows exception
dim w as new BugReporter
dim e as RuntimeException = nil
buf=nil // release memory
if UBound(BackTraceLines) < 0 then
// Raise Exception so we have a stack trace in case we have no backtrace
#Pragma BreakOnExceptions false
try
dim re as new RuntimeException
re.Message = "Dummy Exception to get stack trace."
raise re
catch r as RuntimeException
e = r
end try
#Pragma BreakOnExceptions true
end if
w.BackTraceLines = BackTraceLines
w.SetClassificationBugReport
w.ReasonText = exceptionname
w.Reason.text = kReasonException+exceptionname
w.SetDetails e
w.CheckSending
w.ShowModal
End Sub
Shared Function UnhandledException(error as RuntimeException) As Boolean
#Pragma StackOverflowChecking false
// shows bug report dialog for unhandled exceptions
buf=nil // release memory
if app.CurrentThread <> nil then
// got exception on thread
DelayedException = error
delayedTimer = new timer
AddHandler delayedTimer.action, AddressOf UnhandledExceptionTimerAction
delayedTimer.mode = 1
delayedTimer.Period = 0
Return true
end if
dim ExceptionName as string = GetExceptionName(error)
System.DebugLog ExceptionName
System.DebugLog error.message
dim w as new BugReporter
w.ReasonText = ExceptionName
w.SetClassificationBugReport
w.Reason.text=kReasonException+" "+ExceptionName
w.SetDetails error
w.CheckSending
w.ShowModal
if BugReporterConfiguration.AllowContinueAfterException then
Dim d as New MessageDialog //declare the MessageDialog object
Dim b as MessageDialogButton //for handling the result
d.icon=MessageDialog.GraphicCaution //display warning icon
d.ActionButton.Caption=kquitLabel
d.CancelButton.Visible= false //show the Cancel button
d.AlternateActionButton.Visible= True //show the “Don’t Save” button
d.AlternateActionButton.Caption=kContinueLabel
d.Message=kContinueQuestion
d.Explanation=kContinueExplanation
b=d.ShowModal //display the dialog
Select Case b //determine which button was pressed.
Case d.ActionButton
// ExitMBS does not call the RB code to cleanup.
ExitMBS(1)
'quit
Case d.AlternateActionButton
// continue
End select
Return true
else
// ExitMBS does not call the RB code to cleanup.
ExitMBS(1)
'quit
Return false
end if
End Function
Private Shared Sub UnhandledExceptionTimerAction(t as timer)
#pragma Unused t
delayedTimer = nil
call UnhandledException DelayedException
DelayedException = nil
End Sub
Shared Sub init()
#Pragma StackOverflowChecking false
// Initialize the bugreporter, register your MBS Plugins before calling this!
// We store a memoryblock with 1 MB so we can release that buffer when the error happens
// this is to have enough memory for displaying the dialog if the error was caused because of low memory
buf = New MemoryBlock(1024*1024)
#if TargetWin32 then
// Windows
static MyWinException as new MyWinExceptionMBS
#Pragma unused MyWinException
#else
// Mac or Linux
static MySignalHandler as new MySignalHandlerMBS
const SIGILL=4
const SIGTRAP=5
const SIGABRT=6
const SIGFPE=8
const SIGKILL=9
const SIGBUS=10
const SIGSEGV=11
const SIGALRM=14 // Alarm
const SIGTERM=15
call MySignalHandler.SetEventHandler SIGILL
call MySignalHandler.SetEventHandler SIGTRAP
call MySignalHandler.SetEventHandler SIGABRT // if we disable this one we can't use AbortMBS in the signal handler
call MySignalHandler.SetEventHandler SIGFPE
call MySignalHandler.SetEventHandler SIGKILL
call MySignalHandler.SetEventHandler SIGBUS
call MySignalHandler.SetEventHandler SIGSEGV
call MySignalHandler.SetEventHandler SIGTERM
call MySignalHandler.SetEventHandler SIGALRM
#endif
MyGlobalExceptionHandler = new MyGlobalExceptionHandlerMBS
// call once to initialize
dim r as new RuntimeException
call GetObjectClassName(r)
End Sub
Private Function log(s as string="") As string
#Pragma StackOverflowChecking false
// as app may crash getting details we copy them to the console
System.DebugLog s
Return s
End Function
Shared Sub showBugReport()
#Pragma StackOverflowChecking false
// shows bug report so customer can enter his own bug
dim w as new BugReporter
w.SetDetails
w.Reason.text=kReasonBugReport
w.SetClassificationBugReport
w.CheckSending
w.ShowModal
End Sub
Shared Sub showFeatureRequest()
#Pragma StackOverflowChecking false
// shows dialog for user to send in a feature request
dim w as new BugReporter
w.ReasonText = "Feature Request"
w.StaticText4.text=kFeatureRequest
w.Reason.text=kReasonFeature
w.SetDetails
w.SetClassificationFeatureRequest
w.DisableSteps
w.CheckSending
w.ShowModal
End Sub
Note "Features"
1. One line to send bug report
2. One line to send feature request
3. One line to handle unhandled exceptions
4. Can check for existing crash reports
5. If no internet connection, the report can be saved as text file
6. If internet script fails, the report can be saved as text file
7. Configuration with extra Module where you can enable exceptions that need plugins
8. Localization possible. Currently German and English
9. Adds system information, Application details and exception details to the report
10. user can remove details if they care for privacy
Property Private BackTraceLines() As string
Property Private Shared CompanyName As String
Property Private Shared CompanyNameReadOnly As Boolean
Property Private Shared CustomData As string
Property Private Shared DelayedException As RuntimeException
Property Private Shared EmailAddress As string
Property Private Shared EmailAddressReadonly As Boolean
Property Private HaveInternet As Boolean
Property Protected Shared MyGlobalExceptionHandler As MyGlobalExceptionHandlerMBS
Property Private ReasonText As string
Property Private Shared buf As MemoryBlock
Property Private Shared delayedTimer As timer
Property Protected iDetails As string
End Class
Class MyWinExceptionMBS Inherits WinExceptionMBS
EventHandler Function GotException() As integer
#Pragma StackOverflowChecking false
dim BackTraceLines() as string
#if TargetConsole
BugReporterConsole.ShowExceptionReporter me.ExceptionName+" at "+hex(me.ExceptionAddress), BackTraceLines
#else
BugReporter.ShowExceptionReporter me.ExceptionName+" at "+hex(me.ExceptionAddress), BackTraceLines
#endif
// die silently
Return kExecuteHandlerNoDialog
End EventHandler
End Class
Class MySignalHandlerMBS Inherits SignalHandlerMBS
EventHandler Sub Signal(n as integer)
#Pragma StackOverflowChecking false
// Mac and Linux can have different signal numbers:
#if TargetMacOS then
dim c as string = "Signal "+str(n)+" on Mac OS X"
#elseif TargetLinux then
dim c as string = "Signal "+str(n)+" on Linux"
#else
dim c as string = "Signal "+str(n)+" on ?"
#endif
// restore system default if we crash again now for same signal
call MySignalHandlerMBS.SetDefaultHandler n
dim BackTraceLines() as string
#if mbs.BuildNumber>17662 and not TargetWin32 then // new in 13.0 plugins
BackTraceLines = BacktraceMBS
#endif
#if TargetConsole
BugReporterConsole.ShowExceptionReporter c, BackTraceLines
#else
BugReporter.ShowExceptionReporter c, BackTraceLines
#endif
// quit now without cleaning up the RB runtime which may crash again
ExitMBS 1
End EventHandler
End Class
End Project
See also:
The items on this page are in the following plugins: MBS Util Plugin.