//TH-Header
//*****************************************************************************************
// Copyright (c)  2014  KURANT Project
// All rights reserved.
//
// $FileName    : cReadSrc.pkg
// $ProjectName : The Hammer 2.0
// $Authors     : Wil van Antwerpen, Michael Kurz, Sergey V. Natarov, Bernhard Ponemayr
// $Created     : 01.25.2014  01:08
// $Type        : LGPL
//
// Contents: 
//
//*****************************************************************************************
//TH-RevisionStart
//TH-RevisionEnd

// SCANNING OF SOURCEFILE


//Function fReadSrcLine GLOBAL returns string
//    local string sLine sRet
//    local integer iStop
//    repeat
//        readln sLine
//        trim sLine to sLine
//        get fStripComment sLine to sLine
//        if not ';' in sLine move 1 to iStop
//        append sRet sLine
//    until (iStop or (seqeof))
//    Function_Return sRet
//End_Function

//Function fCheckInClass string sStr Returns string
//    Function_Return (pos(' CLASS ',uppercase(' ' + sStr))
//End_Function

// Strip path from filename
function  fBase_file_Name GLOBAL string sIn returns string
    String sDirSep
    integer iLen iCnt
    Move (Sysconf(SYSCONF_DIR_SEPARATOR)) To sDirSep

    Move (Length(sIn)) to iLen
    Move iLen to iCnt
    While iCnt Gt 0
      If (Mid(sIn,1,iCnt)) Eq sDirSep Function_Return (Right(sIn,iLen-iCnt))
      Decrement iCnt
    End // While iCnt Gt 0
    Function_return sIn
end_function

// Return path only
Function fDirectory_Filename global string sIn Returns string
    String sDirSep
    integer iLen iCnt
    Move (Sysconf(SYSCONF_DIR_SEPARATOR)) To sDirSep

    Move (Length(sIn)) to iLen
    Move iLen to iCnt
    While iCnt Gt 0
      If (Mid(sIn,1,iCnt)) Eq sDirSep Function_Return (left(sIn,iCnt-1))
      Decrement iCnt
    End // While iCnt Gt 0
    Function_return sIn
End_Function

Function fFull_Filename_NotExt global string sIn Returns string
    integer iLen iCnt

    Move (Length(sIn)) to iLen
    Move iLen to iCnt
    While iCnt Gt 0
      If (Mid(sIn,1,iCnt)) Eq '.' Function_Return (left(sIn,iCnt-1))
      Decrement iCnt
    End // While iCnt Gt 0
    Function_return sIn
End_Function

// I made this a class so I can use for other purposes

Class cReadSource is a BusinessProcess

    Procedure Construct_object
        forward send Construct_Object

        set process_title to 'Reading Source Code'

        // Sourcefile to read if reading directly from file.Source will be put in oSrcCode_Array
        property string psFileName public ''

        // If source is already in an array, id of array
        property integer phSourceArray public 0

        Object oSrcCode_Array Is A array
        End_Object

    End_Procedure

    Function fProperString string sStr Returns string
        integer iLen imakeUp iPos
        string sRet sChar
        move 1 to iMakeUp
        length sStr to iLen
        move '' to sRet
        For iPos FROM 1 to iLen
            mid sStr to sChar 1 iPos
            if iMakeUp move (Uppercase(sChar)) to sChar
            else       move (Lowercase(sChar)) to sChar
            append sRet sChar
            move 0 to iMakeUp
            if sChar eq '_' move 1 to iMakeUp
        Loop
        Function_Return sRet
    End_Function

    // Read file to Array
    Function fReadFile string sFileName Returns integer
        integer iCount hArr
        string sLine
        get oSrcCode_Array to hArr
        send delete_data to hArr
        direct_input sFileName
        While [not seqeof]
            readln sLine
            [not seqeof] Begin
                set array_value of hArr item iCount to sLine
                increment iCount
            End
        end
        close_input
        Function_Return iCount
    End_Function

    Function fCommentSign Returns string
        Function_Return ('/'+'/')
    End_Function

    Function fStripComment string sStr Returns string
        string sSrchstr
        get fCommentSign to sSrchStr
        if sSrchStr in sStr function_return (left(sStr,(pos(sSrchstr,sStr)-1)))
        else function_return sStr
    End_Function

    Function fExtractComment string sStr Returns string
        integer ipos
        string sRet
        pos ('/'+'/') in sStr to iPos
        if iPos ne 0 right sStr to sRet (length(sStr) - iPos +1)
        move (trim(replace(('/'+'/'),sRet,''))) to sRet

        Function_Return sRet
    End_Function

    // Check if string is embedded in string constant i.e " or '
    Function fIsInStringConstant string sStr integer iStrPos Returns integer
        integer iLen iPos iStartSym iEndSym iIsSym
        string sChar sSymChar
        length sStr to iLen
        For iPos From 1 to iLen
            mid sStr to sChar 1 iPos
            move (sChar='"' or sChar="'") to iIsSym
            if (iStartSym and iIsSym and sChar = sSymChar) move iPos to iEndSym // End of string constant
            if (iStartSym=0 and iIsSym) Begin                                   // Start of string constant
                move iPos to iStartSym
                move sChar to sSymChar
            End
            if (iStartSym and iEndSym) Begin
                // String pos is inside a string constant
                if (iStrPos >= iStartSym and iStrPos <= iEndSym) function_return 1
                else Begin
                    // Continue looking
                    move 0 to iStartSym
                    move 0 to iEndSym
                    move '' to sSymChar
                End
            End
        Loop
        Function_Return 0
    End_Function

    Function fIsInExpression string sStr integer iStrPos Returns integer
        integer ilen iPos istartSym iEndSym iLevel
        string sChar
        length sStr to iLen
        For iPos From 1 to iLen
            mid sStr to sChar 1 iPos
            if sChar eq '(' begin
                if iLevel eq 0 move iPos to iStartSym
                increment iLevel
            end
            if sChar eq ')' begin
                decrement iLevel
                if iLevel eq 0 move iPos to iEndSym
            end
            if (iStartSym and iEndSym) Begin
                // String pos is inside a string constant
                if (iStrPos >= iStartSym and iStrPos <= iEndSym) function_return 1
                else Begin
                    // Continue looking
                    move 0 to iStartSym
                    move 0 to iEndSym
                End
            End
        loop

        Function_Return 0
    End_Function

    // Search string for keyword sKeyword in string sStr starting at iStartPos
    Function fFindKeyWord string sStr string sKeyWord integer iStartPos0 Returns integer
        string sOrgStr sCommSym
        integer iFoundPos iRealPos iStartPos

        move sStr to sOrgStr
        move ('/'+'/') to  sCommSym
        if NUM_ARGUMENTS lt 3 move 1 to iStartPos
        else move iStartPos0 to iStartpos
        if iStartPos le 0 move 1 to iStartPos

        if iStartPos gt 1 right sStr to sStr (Length(sStr)- iStartPos + 1)

        move (Uppercase(sStr)) to sStr
        move (Uppercase(sKeyword)) to sKeyword

        move (pos((' ' + sKeyword + ' '), ( ' '+ sStr + ' '))) to iFoundPos
        if not iFoundPos function_return 0

        move (iFoundPos+iStartPos-1) to iRealPos

        if iFoundPos Begin
            // Check if inside comment
            if (iFoundPos > (pos(sCommSym, sStr)) and (pos(sCommSym, sStr))) function_return 0
            // Check if inside a string constant. If true search again
            if (fIsInStringConstant(self, sOrgStr, iRealPos)) get fFindkeyWord sOrgstr sKeyWord (iRealPos+length(sKeyword)+1) to iRealPos
            if (fIsInExpression(self, sOrgStr, iRealPos)) get fFindkeyWord sOrgstr sKeyWord (iRealPos+length(sKeyword)+1) to iRealPos
        End

        Function_Return iRealPos
    End_Function

    // Get first word on line
    Function fFirstKeyWord string sStr Returns integer
        move (Uppercase(trim(sStr))) to sStr

        Function_Return (left(sStr,(pos(' ', sStr)-1)))
    End_Function

    // Check if sStr starts with sKeyword
    Function fIsFirstKeyWord string sStr string sKeyword Returns integer
        move (Uppercase(sKeyword +' ')) to sKeyword
        move (Uppercase(trim(sStr))) to sStr

        Function_Return (if(left(sStr,length(sKeyword)) = sKeyword, 1 , 0))
    End_Function

    // Finds Word in string. Use other delimiters than space
    Function fFindWord string sStr string sKeyword integer iStartPos0 string sDlm0 Returns integer
        string sOrgStr sCommSym sDlm
        integer iFoundPos iRealPos iStartPos iUseParen

        move sStr to sOrgStr
        move ('/'+'/') to  sCommSym
        if NUM_ARGUMENTS lt 3 move 1 to iStartPos
        else move iStartPos0 to iStartpos
        if iStartPos le 0 move 1 to iStartPos

        if NUM_ARGUMENTS lt 4 move ' ,;{}[]' to sDlm
        else move sDlm0 to sDlm

        if iStartPos gt 1 right sStr to sStr (Length(sStr)- iStartPos + 1)

        move (Uppercase(sStr)) to sStr
        move (Uppercase(sKeyword)) to sKeyword

        move (sDlm contains '(' ) to iUseParen // if delimiter icontains parenthesis then don't check if word is in expression

        move (' '+ sStr + ' ') to sStr
        move (pos(sKeyword, sStr )) to iFoundPos
        if not iFoundPos function_return 0

        move (iFoundPos+iStartPos-2) to iRealPos

        if iFoundPos Begin
            // Check if inside comment
            if (iFoundPos > (pos(sCommSym, sStr)) and (pos(sCommSym, sStr))) function_return 0
            if not (sDlm contains mid(sStr,1,(iFoundPos-1)) and sDlm contains mid(sStr,1,(iFoundPos+length(sKeyword)))) ;
               get fFindWord sOrgstr sKeyWord (iRealPos+length(sKeyword)+1) sDlm to iRealPos
            // Check if inside a string constant. If true search again
            if (fIsInStringConstant(self, sOrgStr, iRealPos)) get fFindWord sOrgstr sKeyWord (iRealPos+length(sKeyword)+1) sDlm to iRealPos
            if (fIsInExpression(self, sOrgStr, iRealPos) and not(iUseParen)) get fFindkeyWord sOrgstr sKeyWord (iRealPos+length(sKeyword)+1) sDlm to iRealPos
        End

        Function_Return iRealPos

    End_Function

    // Finds keyword at positon. Use other delimiters than space
    Function fWordAtPos string sStr integer iStartPos0 string sDlm0 Returns string
        integer ilen iPos iPos2 istartpos iUseParen
        string sChar sDlm


        if NUM_ARGUMENTS eq 1 move 1 to iStartPos
        else move iStartPos0 to iStartPos
        if NUM_ARGUMENTS le 2 move ' ,;{}[]' to sDlm
        else move sDlm0 to sDlm

        move (sDlm contains '(' ) to iUseParen // if delimiter icontains parenthesis then don't check if word is in
        move (sStr+' ') to sStr
        length sStr to iLen
        // If we are already on a blank, go to start of first word
        if (mid(sStr,1,iStartPos)) in sDlm Begin
            For iPos from iStartpos to iLen
                if not (mid(sStr,1,iPos)) in sDlm break
            Loop
            move iPos to iStartPos
        End
        For iPos From iStartPos to iLen
            // if character is not delimiter
            if not (mid(sStr,1,iPos)) in sDlm Begin
                For iPos2 From iPos to iLen
                    if ( sDlm contains (mid(sStr,1,iPos2)) and not(fIsInStringConstant(self, sStr, ipos2)) and (if(iUseParen,1,not(fIsInExpression(self, sStr, ipos2)))))  ;
                        function_return (mid(sStr, (iPos2-iPos), iPos))
                Loop
            End
        Loop
        Function_Return ''
    End_Function

    Function fKeywordAtPos string sStr integer iStartPos0 Returns string
        integer ilen iPos iPos2 istartpos

        if NUM_ARGUMENTS eq 1 move 1 to iStartPos
        else move iStartPos0 to iStartPos
        move (sStr+' ') to sStr
        length sStr to iLen
        // If we are already on a blank, go to start of first word
        if (Ascii(mid(sStr,1,iStartPos))) le 32 Begin
            For iPos from iStartpos to iLen
                if (Ascii(mid(sStr,1,iPos))) gt 32 break
            Loop
            move iPos to iStartPos
        End
        For iPos From iStartPos to iLen
            // if character is not blank
            if (Ascii(mid(sStr,1,iPos))) gt 32 Begin
                For iPos2 From iPos to iLen
                    if ((Ascii(mid(sStr,1,iPos2))) <=32 and not(fIsInStringConstant(self, sStr, ipos2)) and not(fIsInExpression(self, sStr, ipos2))) ;
                        function_return (mid(sStr, (iPos2-iPos+1), iPos))
                Loop
            End
        Loop
        Function_Return ''
    End_Function

    Function fNextKeywordPos  string sStr integer iStartPos0 Returns integer
        integer ilen iPos iPos2 iStartpos
        if NUM_ARGUMENTS eq 1 move 1 to iStartPos
        else move iStartPos0 to iStartPos
        if iStartPos le 0 move 1 to iStartpos
        move (sStr+' ') to sStr
        length sStr to iLen

        // Go to end of current keyword

        move iStartPos to iPos
        repeat
            // if character is blank
            if (Ascii(mid(sStr,1,iPos)) = 32 and not(fIsInStringConstant(self, sStr, iPos)) and not(fIsInExpression(self, sStr, iPos))) begin
                For iPos2 From iPos to iLen
                    if (Ascii(mid(sStr,1,iPos2))) gt 32 function_return iPos2
                Loop
            end
            increment iPos
        until (iPos >= iLen)

        Function_Return 0
    End_Function

    // Return next keyword after current position
    Function fNextKeyWord string sStr integer istartPos0 Returns string
        integer ilen iPos iPos2 iStartpos
        if NUM_ARGUMENTS eq 1 move 1 to iStartPos
        else move iStartPos0 to iStartPos
        if iStartPos le 0 move 1 to iStartpos
        get fNextkeywordPos sStr iStartPos to iStartPos
        get fKeywordAtPos sStr iStartPos   to sStr

        Function_Return sStr
    End_Function

    // replace word in string
    Function fReplaceWord string sStr string sNewWord string sOldWord Returns string
        integer iPos iLen
        length sOldWord to iLen
        move 1 to iPos
        repeat
            get fFindWord sStr sOldWord iPos ' (),' to ipos
            if iPos move (left(sStr,(iPos-1)) + sNewWord + mid(sStr, length(sStr), (iPos+iLen))) to sStr
        until iPos eq 0

        Function_Return sStr
    End_Function

    // Checks if string is a procedure definition and if sprocname is passed it checks if Procedure is sProcname
    Function fIsProcedure string sStr string sProcname Returns integer
        integer iIsProc
        get fIsFirstKeyword sStr 'Procedure' to iIsProc
        if (iIsProc and sProcName <> '') Begin
            get fFindKeyWord sStr sProcName 0 to iIsproc
        End
        Function_Return iIsProc
    End_Function

    Function fClassName string sStr Returns string
        trim sStr to sStr
        Function_Return (fKeywordAtPos(self, sStr, 6))
    End_Function

    Function fSuperClassName string sStr Returns string
        string sDummy
        integer iPos
        get fStripComment sStr to sStr

        get fFindKeyword sStr 'is' to iPos
        get fKeywordAtPos sStr (iPos+2) to sDummy //a or an
        get fKeywordAtPos sStr (iPos+3+Length(sDummy)) to sStr
        Function_Return sStr
    End_Function

    Function fIsObject string sStr Returns integer
        integer iIsObj
        get fIsFirstKeyword sStr 'OBJECT' to iIsobj
        if not iIsobj get fIsFirstKeyword sStr 'CD_POPUP_OBJECT' to iIsobj
        Function_Return iIsObj
    End_Function

    Function fIsEnd_Object string sStr Returns integer
        integer iIsEndObj
        get fIsFirstKeyword sStr 'END_OBJECT' to iIsEndobj
        if not iIsEndobj get fIsFirstKeyword sStr 'CD_END_OBJECT' to iIsEndobj
        Function_Return iIsEndObj
    End_Function

    Function fObjectName string sStr Returns string
        trim sStr to sStr
        IF (fIsFirstKeyword(self, sStr ,'OBJECT'))          function_return (fKeywordAtPos(self, sStr, 8))
        if (fIsFirstKeyword(self, sStr ,'CD_POPUP_OBJECT')) function_return (fKeywordAtPos(self, sStr, 17))
        Function_Return ''
    End_Function

    Function fGuessDataType string sArg Returns string
        string sFirstChar
        move (trim(Uppercase(sArg))) to sArg
        left sArg to sFirstChar 1
        if (sFirstChar='"' or sFirstChar="'")       function_return 'String'
        if (sFirstChar <> '(' and pos(' ', sArg))   function_return 'Complex'
        if (sArg = 'TRUE' or sArg ='FALSE')         function_return 'Boolean'
        if (sFirstChar <> '(' and (sFirstChar >= '0' and sFirstChar <= '9') and pos('.',sArg)=0) function_return 'Integer'
        if (sFirstChar <> '(' and (sFirstChar >= '0' and sFirstChar <= '9') and pos('.',sArg)) function_return 'Number'
        Function_Return ''
    End_Function

    Function fReadSourceFile string sFileName Returns integer
        integer iRet
        set psFileName to sFileName
        send doProcess
        Function_Return 1
    End_Function

End_Class

Procedure pWriteArraytoFile integer hArr integer iElements string sFileName
    integer imax iRow iItem iItemS
    string sval sLine
    move ((Item_Count(hArr)/iElements)-1) to iMax
    if imax lt 0 procedure_return
    direct_output sFileName
    For iRow From 0 to iMax
        move (iRow*iElements) to iItemS
        move '' to sLine
        For iItem From 0 to (iElements-1)
            get string_value of hArr item (iItemS+iItem) to sVal
            append sLine sVal ' '
        loop
        writeln (rtrim(sLine))
    Loop
    close_output

End_Procedure