The Hammer » VDF Splat

//TH-Header

//*****************************************************************************************

// Copyright (c)  2013 Antwise Solutions

// All rights reserved.

//

// $FileName    : cSplatCodemax.pkg

// $ProjectName : Vdf Debugger

// $Authors     : Wil van Antwerpen

// $Created     : 12.14.2013  23:50

// $Type        : GPLv2

//

// Contents:

//

//*****************************************************************************************

//TH-RevisionStart

//TH-RevisionEnd

Use cComCodeMax.pkg

Use cImageList32.pkg

Use RGB.pkg

Use cOSVersionInfo.pkg

//Use cComCDACTreeListCtl.pkg

Define CS_LNG_VDF for "Visual DataFlex"

Define CS_DAW_KEY for "Data Access Worldwide"

Define CS_DAW_VDF for "Visual DataFlex"

Define CS_DAW_DF  for "DataFlex"

Define CS_TAB     for (Character(9))

Define ICO_Brkp_obj     for $CI01 // breakpoint object icon

Define ICO_Inst_ptr     for $CI02 // instruction pointer icon

Define ICO_Inst_ptr_top for $CI04 // instruction pointer top icon

Class cCodeMaxImageList is a cImageList32

  Procedure Construct_Object

    Forward Send Construct_Object

    Set piMaxImages To 5

    Set piImageHeight To 16

    Set piImageWidth  To 16

  End_Procedure // Construct_Object

  Procedure OnCreate

    Integer iVoid

    Get AddImage "brkp_obj.ico"     To iVoid // bit 1 // seems the first image is ignored as a margin image

    Get AddImage "inst_ptr_top.ico" To iVoid // bit 2

    Get AddImage "brkp_obj.ico"     To iVoid // bit 3

    Get AddImage "inst_ptr.ico"     To iVoid // bit 4

  End_Procedure

End_Class

Class cSplatCodeMax is a cComCodeMax

  Procedure Construct_Object

    Forward Send Construct_Object

    Property String  psFileName     ""

    Property Integer piCurrentLine  0

    Object oCodeMaxImages is a cCodeMaxImageList

    End_Object

  End_Procedure

  Function HostOSis64Bits Returns Boolean

    Handle  hoVersionInfo

    Boolean bIs64Bits

    Move false to bIs64Bits

    Get Create U_cOSVersionInfo To hoVersionInfo

    If (hoVersionInfo) Begin

      Get pbX64  Of hoVersionInfo To bIs64Bits

    End

    Function_Return bIs64Bits

  End_Function // HostOSis64Bits

  // Returns compiled runtime version as DataFlex version * 10

  Function CompiledRuntimeVersion Returns Integer

    String  sVersion

    Integer iVersion

    Move (Replace(".",gsRuntimeVersion,"")) To sVersion

    Move (Cast(sVersion,integer)) To iVersion

    Function_Return iVersion

  End_Function

  //

  // Runtime folder that is used for compiling the current version of Splat.

  // This helps us in getting the required parameters

  //

  Function CurrentRuntimeFolder Returns String

    Boolean bOpened

    Boolean bExists

    Handle  hoRegistry

    String  sKey

    String  sPath

    Integer iVersion

    Move "" To sPath

    Get Create U_cRegistry to hoRegistry

    If (hoRegistry) Begin

      Set phRootKey of hoRegistry to HKEY_LOCAL_MACHINE

      Set pfAccessRights of hoRegistry to Key_Read

      // check if this is a 64 bit machine

      // if so, the Wow6432Node key will exist <- unreliable test as it turns out

      //Get KeyExists of hoRegistry "SOFTWARE\Wow6432Node" to bExists

      Get HostOSis64Bits To bExists

      If bExists Begin

          Move (Append("SOFTWARE\Wow6432Node\", CS_DAW_KEY)) to sKey

      End

      Else Begin

          Move (Append("SOFTWARE\", CS_DAW_KEY)) to sKey

      End

      Get KeyExists of hoRegistry sKey to bExists

      If bExists Begin

          Get CompiledRuntimeVersion To iVersion

          If (iVersion<180) Begin

            Move (sKey+"\"+CS_DAW_VDF+"\"+gsRuntimeVersion+"\Defaults\") To sKey

          End

          Else Begin

            Move (sKey+"\"+ CS_DAW_DF+"\"+gsRuntimeVersion+"\Defaults\") To sKey

          End

          Get OpenKey of hoRegistry sKey to bOpened

          If bOpened Begin

            Get ReadString of hoRegistry "VDFRootDir" To sPath

            Send CloseKey of hoRegistry

          End

      End

      Send Destroy of hoRegistry

    End

    Function_Return sPath

  End_Function // CurrentRuntimeFolder

  Procedure LoadVDFLanguageDefinition

    Boolean bCreated

    Boolean bExists

    String  sRootDir

    String  sLibDir

    String  sLanguageFile

    Integer iVersion

    Handle  hoLanguage

    Variant vLanguage

    Get Create U_cComlanguage To hoLanguage

    If (hoLanguage) Begin

      Send CreateComObject of hoLanguage

      Get IsComObjectCreated Of hoLanguage To bCreated

      If (bCreated) Begin

        Get CurrentRuntimeFolder to sRootDir

        If (sRootDir<>"") Begin

          Get vFolderFormat sRootDir To sRootDir

          Move (sRootDir+"Lib\") To sLibDir

          Get CompiledRuntimeVersion to iVersion

          If (iVersion<180) Begin

            Move (sLibDir+"VisualDataFlex.lng") To sLanguageFile

          End

          Else Begin

            Move (sLibDir+"DataFlex.lng") To sLanguageFile

          End

          Get vFilePathExists sLanguageFile to bExists

          If (bExists) Begin

            Send ComLoadXmlDefinition of hoLanguage sLanguageFile

            Set ComName of hoLanguage To CS_LNG_VDF

            Send ComRegister of hoLanguage

            Get pvComObject of hoLanguage To vLanguage

            Set ComLanguage To vLanguage

            Send Destroy of hoLanguage

          End

          Else Begin

            Send Info_Box ("Can't load language for runtime"*gsRuntimeVersion*"Couldn't find language file\n"*sLanguageFile)

          End

        End

        Else Begin

          Send Info_Box ("Can't load language as unable to determine runtime folder for VDF"*gsRuntimeVersion)

        End

      End

    End

  End_Procedure // LoadVDFLanguageDefinition

  //

  // Returns line numbers starting from line 0 (not line 1)

  // Columns numbers are also zero based

  //

  Function CurrentPosition Variant vPos Integer Byref iLine Integer Byref iColumn Returns Boolean

    Boolean bOK

    Handle  hoPos

    Move false To bOK

    Get Create (RefClass(cComPosition)) To hoPos

    If (hoPos) Begin

      Set pvComObject of hoPos to vPos

      Get ComLineNo of hoPos To iLine

      Get ComColNo  of hoPos To iColumn

      Send Destroy of hoPos

      Move True To bOk

    End

    Function_Return bOK

  End_Function

  Function CurrentLine Returns Integer

    Boolean bOK

    Integer iOffset

    Integer llLine

    Integer llColumn

    Integer iLine

    Variant vPos

    Move 0 To iLine

    Get ComSelStart to iOffset

    //Get ComSelEnd to llColumn

    Get ComOffsetToPos iOffset to vPos

    //Get ComGetSel False to vSel

    Get CurrentPosition vPos (&llLine) (&llColumn) To bOK

    If (bOK) Begin

      Move (llLine+1) To iLine  // +1 because line number returned is zero based.

    End

    If (llLine=0 and piCurrentLine(Self)<>0) Begin

      // .. not great ..

      // if file was opened via stack and this window does not yet have the focus by clicking

      // into the file, it will return line 0, as a result setting a breakpoint isn't reliable

      // so... we use this ugly workaround.

      Get piCurrentLine To iLine

    End

    Function_Return iLine

  End_Function

  Function WordAtPositionDoesNotWork Integer iLine Integer iColumn Returns String

    String  sWord

    String  sLeadingChar

    String  sTrailingChar

    Handle  hoPos

    Variant vPos

    Get Create (RefClass(cComPosition)) to hoPos

    If (hoPos) Begin

      Send CreateComObject to hoPos

      Set ComLineNo   of hoPos to iLine

      Set ComColNo    of hoPos to iColumn

      Get pvComObject of hoPos to vPos

      Move " (=+-*"  to sLeadingChar

      Move " ()=+-*" to sTrailingChar

      // Won't work ComGetWordEx does not stop on any of the above characters

      Get ComGetWordEx vPos sLeadingChar sTrailingChar to sWord

      Send Destroy of hoPos

    End

    Function_Return sWord

  End_Function

  Function WordAtLinePosition String sLine Integer iColumn Returns String

    String  sWord

    String  sLeadingChar

    String  sTrailingChar

    String  sChar

    Integer iChar

    Integer iStart

    Integer iEnd

    Integer iLength

    Boolean bStop

    Move (CS_TAB+" (=+-*")   To sLeadingChar

    Move (CS_TAB+" ()=+-*")  to sTrailingChar

    Move False to bStop

    Move iColumn to iChar

    if (iColumn>0) begin

      While not bStop

        Move (Mid(sLine,1,iChar)) To sChar

        If (iChar<=0 or sLeadingChar contains sChar) begin

          Move True To bStop

          Move (iChar+1) To iStart

        End

        Decrement iChar

      Loop

    End

    Move (length(sLine)) To iLength

    For iChar from iColumn To iLength

      Move (Mid(sLine,1,iChar)) To sChar

      If (sTrailingChar contains sChar) begin

        Move (iChar-1) to iEnd

        Move iLength To iChar

      End

    Loop

    If (iEnd=0) Move iLength To iEnd

    Move (Mid(sLine,iEnd-iStart+1,iStart)) To sWord

    Function_Return sWord

  End_Function

  // Returns the word under the specified location.

  // iLine and iColumn are zero based

  //

  Function WordAtPosition Integer iLine Integer iColumn Returns String

    String  sWord

    String  sComment

    String  sLeadingChar

    String  sTrailingChar

    String  sChar

    String  sLine

    Integer iCommentPos

    Integer iChar

    Boolean bBeforeLine

    Get ComGetLine iLine To sLine

    Move "//" to sComment

    Move (Pos(sComment,sLine)) To iCommentPos

    If (iCommentPos>0 and iCommentPos<iColumn and iColumn>0) Begin

      Function_Return "" // caret is in a comment block

    End

    Move " (=+-*"   to sLeadingChar

    Move " ()=+-*"  to sTrailingChar

    Move True to bBeforeLine // test if caret is before any words on the line

    For iChar from 1 to iColumn

      Move (Mid(sLine,1,iChar)) to sChar

      If not ( (sLeadingChar+sTrailingChar) contains sChar ) Begin

        Move False to bBeforeLine

        Move iColumn to iChar

      End

    Loop

    If (bBeforeLine) Begin

      Function_Return "" // before any words

    End

    Get WordAtLinePosition sLine iColumn To sWord

    Function_Return sWord

  End_Function

  //

  // A bunch of parsing problems happen because we don't know how many

  // white space characters exist. This replaces multiple WS characters to just

  // one space character.

  //

  Function SingleWhiteSpaceLine String sLine Returns String

    Integer iLength

    Integer iChar

    Boolean bPrevWSChar

    String  sChar

    String  sSWSLine

    String  sWSChars

    Move "" To sSWSLine

    Move (CS_TAB+" ") To sWSChars

    Move (length(sLine)) To iLength

    Move False To bPrevWSChar

    For iChar From 1 To iLength

      Move (Mid(sLine,1,iChar)) to sChar

      If (sWSChars contains sChar) begin

        If (bPrevWSChar=false) Begin

          Move True To bPrevWSChar

          Move (sSWSLine+" ") To sSWSLine

        End

      End

      Else Begin

        Move False To bPrevWSChar

        Move (sSWSLine+sChar) To sSWSLine

      End

    Loop

    Function_Return sSWSLine

  End_Function

  //

  // Tries to locate the object (or variable) in a notation like

  // Get Property Of oObject To

  // which should return oObject

  //

  Function IsPropertyOf String sProperty Integer iline Integer iColumn Returns String

    Integer iPos

    Integer iLength

    Integer iObj

    String  sObject

    String  sLine

    String  sXLine

    String  slLine

    Move "" To sObject

    Get ComGetLine iLine To sLine

    If (sLine<>"") Begin

      Get SingleWhiteSpaceLine sLine To sXLine

      Move (lowercase(sXLine)) To slLine

      Move (Pos(lowercase(sProperty)+" of ",slLine)) To iPos

      If (iPos) Begin

        Move (Length(sProperty+" of ")) To iLength

        Move (iPos+iLength+1) To iObj

        Get WordAtLinePosition sXline iObj To sObject

      End

    End

    Function_Return sObject

  End_Function

  //

  // Properties that are queried which are not local to the focused object will need to

  // be referenced in order to get the correct data back.

  // This code will try to parse out the object.

  //

  Function ObjectForProperty String sProperty Integer iLine Integer iColumn Returns String

    String sObject

    String sOfObject

    String sLine

    Move "Self" To sObject  // the default target object is self

    Get IsPropertyOf sProperty iLine iColumn To sOfObject

    If (sOfObject<>"") Begin

      Move sOfObject To sObject

    End

    Function_Return sObject

  End_Function

  Procedure OnComQuickInfo Integer llLine Integer llColumn String ByRef llTipText

    Handle  hoDebugger

    String  sWord

    String  sResult

    String  sObjectID

    String  sObjectName

    String  sType

    String  sTargetObject

    Boolean bIsProperty

    Boolean bIsProcedure

    Boolean bIsObject

    Boolean bIsKeyword

    Boolean bPaused

    Boolean bOK

    // Does not always return what we need

    //Get ComCurrentWord To sWord  // gets word under cursor

    Move False To bOk

    Get WordAtPosition llLine llColumn To sWord

    If (sWord<>"") Begin

      Get phoDebugger To hoDebugger

      If (hoDebugger) Begin

        Move ""    To sResult

        Move ""    To sType

        Move False To bIsObject

        Get pbProgramPaused    Of hoDebugger To bPaused

        If (bPaused) Begin

          Get IsLanguageKeyword of hoDebugger sWord To bIsKeyword //

          If (bIsKeyword=false) Begin

            Get IsVariableProperty of hoDebugger sWord To bIsProperty

            If (bIsProperty) Begin

              Get ObjectForProperty sWord llLine llColumn to sTargetObject

              Move (sWord+"("+sTargetObject+")") To sWord

              Move "Property " To sType

            End

            Else Begin

              Get IsVariableProcedure Of hoDebugger sWord To bIsProcedure

              If (bIsProcedure) Begin

                Move "Procedure " To sType

              End

              Else Begin

                If (lowercase(sWord)="self") Begin

                  Move "Object " To sType

                  Move True     To bIsObject

                End

              End

            End

            Move ("Evaluating "+sType+"'"+sWord+"' results in"+character(10)) To llTipText

            If (bIsProcedure) Begin

              Move "Not evaluating methods." To sResult

            End

            Else Begin

              Get ComEval of hoDebugger sWord (&sResult) to bOK

            End

            If (bOK) Begin

              If (bIsObject) Begin

                Move sResult To sObjectID

                Move ""      To sObjectName

                Get ComEval of hoDebugger ("name("+sObjectID+")") (&sObjectName) to bOK

                If (bOK) Begin

                  Move (sResult+" ("+sObjectName+") ") To sResult

                End

              End

              Move (sResult+character(10)+character(10)+"Eval OK") To sResult

            End

            Else Begin

              Move (sResult+character(10)+character(10)+"Eval Failed") To sResult

            End

          End

          Else Begin

            Move ("Keyword "+sWord) To sResult

          End

        End

        Else Begin

          Move sWord To sResult

        End

        Move (sResult+", line="+trim(llLine+1)*", column="+Trim(llColumn+1)) To sResult

      End

      Else Begin

        Move "Unable to attach to debugger core" To sResult

      End

    End

    Move (llTipText+sResult) To llTipText

  End_Procedure

  Procedure OnCreate

    Handle  hWnd

    Handle  hWndImg

    Handle  hoImgList

    Variant vImageList

//    Boolean bCreated

    Forward Send OnCreate

    // ToDo: Set the ActiveX properties here...

    // ComImageListRef

    // ComHImageList // line margin images

    //Set ComHImageList  To (oEditImages(Self))//vImageList

    Send LoadVDFLanguageDefinition

    //

    Set ComDisplayLeftMargin To True

    Send ComSetColor OLEcmClrLeftMargin clLtGray

    Set ComBorderStyle To OLEcmBorderClient

    //Get Window_Handle of oCodeMaxImages To hWnd

    Get phImageList Of oCodeMaxImages To hWndImg

    //Move (oCodeMaxImages(Self)) To hoImgList

    Set ComHImageList  To hWndImg  //vImageList

    //Set ComImageListRef To hWndImg

  End_Procedure

  Procedure UpdateStatusHelp

    Integer Fg

    Move 1 To Fg

    Send Request_Status_Help Fg

  End_Procedure

  // update status bar when cursor is moving

  Procedure onCaretPosChanged

    Send UpdateStatusHelp

  End_Procedure

  // The caret position changed

  Procedure OnComSelChange

    Send onCaretPosChanged

    Forward Send OnComSelChange

  End_Procedure

  Procedure doOpenSourceFile String sFileName

    String sLanguage

    Variant vLanguage

    Send ComOpenFile  sFileName

    Set psFilename    To sFileName

    Set ComReadOnly To True // NO changes allowed

    Set ComColorSyntax To True

    // Update view hosting our control

    //Send doSetCaptionLabel sFileName

  End_Procedure // doOpenSourceFile

  Procedure doOpenSourceFileAtLine String sFileName Integer iLine

    Integer eBkLineColor

    Integer iTopMostLine

    Boolean bVisible

    Boolean bScrollup

    Move false to bScrollup

    Send doOpenSourceFile sFileName

    Set piCurrentLine to iLine

    Move iLine to iTopMostLine

    If (iLine>5) Begin

      Move (iLine-4) to iTopMostLine // scroll up a bit so we can see context

      Move true to bScrollup

    End

    Send ComSetTopIndex 0 iTopMostLine

    If (iLine>=0) Begin

        Send ComSetMarginImages (iLine-1) ICO_Inst_ptr //ICO_Brkp_obj// 2

        //Set psFilename     of oCodeMax To sFileName

        // Make it visible to the user where we are

        //Move True to bVisible

        //Send ComSelectLine of oCodeMax iLine bVisible

        Move (RGB(223,253,193)) to eBkLineColor

        Send ComSetLineColor (iLine-1) eBkLineColor //clYellow

    End

    Send UpdateStatusHelp

//    Send ComSetLineColor iLine clRed

  End_Procedure // doOpenSourceFileAtLine

End_Class