//***************************************************************************************** // Created '2000 Michael Kurz // // This code can be used in any apllication for free, but must not be sold in any way. // // $FileName : CodeSpy // $ProjectName : Analyse VDF code (class definitions) // $Author : Michael Kurz // $Created : 12-08-2000 @ 00:10 // // The code is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; // without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. // This is free software; you can redistribute it and/or modify it under the terms of the // GNU Lesser General Public License. // License: LGPLv3 - GNU LESSER GENERAL PUBLIC LICENSE Version 3 - http://www.gnu.org/licenses/lgpl.txt // // Contents: // Build a structure of all classes and their Properties, Functions and Procedures // //***************************************************************************************** //TH-RevisionStart // 22.10.2001 12:01 Removed clearing of the Additional Mk SERVER // Objects //TH-RevisionEnd Use Set Use Windows Use DLL Use vWin32fh.pkg #IFNDEF get_GetComputerName External_Function GetComputerName "GetComputerNameA" kernel32.dll Pointer lpszName Pointer lpdwcBuffer Returns Integer #ENDIF #IFNDEF get_WNetGetUser External_Function WNetGetUser "WNetGetUserA" MPR.DLL Pointer lpName Pointer lpUserName Pointer lpLength Returns DWord #ENDIF // Returns a string with trailing Backslashes ("\") character removed... Function RTrimBackSlash Global String sDir Returns String Move (Trim(sDir)) To sDir While ((Right(sDir,1)) = "\") Move (Left(sDir, Length(sDir) - 1)) to sDir End Function_Return sDir End_Function // Parses the path from a string with both path and filename. Function PathFromPath Global String sDir Returns String String sPath sTmp Get ParseFolderName sDir to sPath If (Right(sPath, 1) = "\") Begin Get RTrimBackSlash sPath to sPath // Move (Left(sPath, Length(sPath) - 1)) to sPath End Function_Return sPath End_Function // Parses a filename from a string with both path and file name. Function FileFromPath Global String sDir Returns String String sFileName Get ParseFileName sDir to sFileName Function_Return sFileName End_Function // Function returns an integer <> 0 if passed folder exists. Function Directory_Exist Global String sDir Returns Integer Integer iSeqeof iRetval Get vFolderExists sDir to iRetval Function_Return iRetval End_Function // Creates a folder including all necessary sub-folders. Procedure Make_Directory Global String sDir Integer iRet String sPart1 sPart2 sTmp sLW Move (Left(sDir, Pos("\", sDir))) to sPart1 Move (Replace(sPart1, sDir, "")) to sDir Repeat If (sDir contains "\") Begin Move (Left(sDir, Pos("\", sDir))) to sTmp End Else Begin Move sDir to sTmp End Move (Replace(sTmp, sDir, "")) to sDir // Append sPart1 sTmp Move (sPart1 + sTmp) to sPart1 Get Directory_Exist sPart1 to iRet If (not(iRet)) Begin Make_Directory (ToAnsi(sPart1)) End Until (Trim(sDir) = "") End_Procedure Function ComputerName for Desktop Returns String String sName Get_Environment "COMPUTERNAME" to sName Function_Return sName End_Function Function Network_User_Name for cDesktop Returns String String sName Get_Environment "USERNAME" to sName Function_Return sName End_Function Class DelegateArray is an Array Procedure Construct_Object Forward Send Construct_Object Set Delegation_Mode to Delegate_To_Parent End_Procedure End_Class // The base class for all source components // Can be Class, Procedure, Property, Function Class cCodeComponent is an DelegateArray Procedure Construct_Object Forward Send Construct_Object Object oStringParse is an Array End_Object Object oCommentLines is an Array End_Object Object oParameters is an Array End_Object Set Delegation_Mode to Delegate_To_Parent Property String psName "" Property String psRest "" Property String psType "" Property Integer piCodeLines 0 End_Procedure // Destroys the object and the embedded objects. Procedure DestroyObject Send Destroy_Object to (oParameters(Self)) Send Destroy_Object to (oCommentLines(Self)) Send Destroy_Object to (oStringParse(Self)) Send Destroy_Object End_Procedure // Seperates a String in all by blanks seperated Stringparts Procedure ParseString String sLine String sTmp Handle hoStringParse Move (oStringParse(Self)) to hoStringParse Send Delete_Data to hoStringParse Move (Trim(sLine)) To sLine Repeat If (sLine contains " ") Begin Move (Left(sLine, Pos(" ", sLine))) to sTmp End Else Begin Move sLine to sTmp End Move (Replace(sTmp, sLine, "")) to sLine Move (Trim(sTmp)) to sTmp Move (Trim(sLine)) to sLine If (sTmp <> "") Begin Set Value of hoStringParse item (Item_Count(hoStringParse)) to sTmp End Until (sLine = "") End_Procedure Function ParsedStringPart Integer iNr Returns String Function_Return (Value(oStringParse(Self), iNr)) End_Function Function ParsedStringCount Returns Integer Function_Return (Item_Count(oStringParse(Self))) End_Function // Adds a parameter to the parameter list of // the Element ( function, procedure ) Procedure AddParameter String sP End_Procedure Procedure WriteElement Integer iC Handle hoCommentLines Move (oCommentLines(Self)) to hoCommentLines Writeln (psName(Self)) " " (piCodeLines(Self)) For iC from 0 to (Item_Count(hoCommentLines) - 1) Writeln " " (Value(hoCommentLines, iC)) End Writeln End_Procedure // a emailaddress between < .. > is detected it is changed to a real // html mailto ref. (only one per line!) Function ConvertEmailEntries String sLine Returns String Integer iPos1 iPos2 String sTmp sNew sEmail iL c34 Move (Character(34)) to c34 Move (Pos("<", sLine)) to iPos1 If (iPos1) Begin Move (Pos(">", sLine)) to iPos2 If (iPos2 > iPos1) Begin Move (Mid(sLine, (iPos2 - iPos1 + 1), iPos1)) to sTmp If (sTmp contains "@" and sTmp contains ".") Begin Move (Mid(sTmp, (Length(sTmp) -2), 2)) to sEmail // Append sNew "MichaelKurz@gmx.at" Move (sNew + "MichaelKurz@gmx.at") to sNew Move (Replace(sTmp, sLine, sNew)) to sLine End End End Function_Return sLine End_Function // Adds a comment line... Procedure AddComment String sLine Move (Trim(sLine)) to sLine Move (Right(sLine, Length(sLine) - 2)) to sLine Move (ConvertEmailEntries(Self, sLine)) to sLine // If the line is blank it will not be output, so // just add an asterisk to display as a blank line. If (sLine = "") Begin Move "*" to sLine End Set Value of (oCommentLines(Self)) item (Item_Count(oCommentLines(Self))) to sLine End_Procedure Procedure WriteCommentsHTML Integer iCount iC Move (Item_Count(oCommentLines(Self))-1) To iCount For iC from 0 to iCount // Run in other Writeln (Value(oCommentLines(Self), iCount-iC)) "
" // direction, because it was filled bottom up End End_Procedure Procedure WriteCommentsHTMLNormal Integer iCount iC Move (Item_Count(oCommentLines(Self)) -1) to iCount For iC From 0 To iCount Writeln (Value(oCommentLines(Self), iC)) "
" End End_Procedure End_Class Class cFunctionComponent is a cCodeComponent Procedure WriteElementHTML String c34 sClassName sName Move (Character(34)) to c34 Delegate Get ClassName to sClassName Get psName to sName Writeln "" sName " " (psRest(Self)) " - Function
" Send WriteCommentsHTML Writeln "
" End_Procedure End_Class Class cProcedureComponent is a cCodeComponent Procedure WriteElementHTML String c34 sClassName sName Move (Character(34)) to c34 Delegate Get ClassName to sClassName Get psName to sName Writeln "" sName " " (psRest(Self)) " - Procedure " (psType(Self)) "
" Send WriteCommentsHTML Writeln "
" End_Procedure End_Class Class cPropertyComponent is a cCodeComponent Procedure WriteElementHTML String c34 sClassName sName Move (Character(34)) to c34 Delegate Get ClassName to sClassName Get psName to sName Writeln "" sName " - Property
" Send WriteCommentsHTML Writeln "
" End_Procedure End_Class // List of cCodeComponent Objects... Class cCodeComponentList is an Array Procedure Construct_Object Forward Send Construct_Object Property String psParseStartTag "" Property String psParseEndTag "" Property Integer piPublic 0 Property Integer piMaxLines 10000 Set Delegation_Mode to Delegate_To_Parent End_Procedure // Sends a DestroyObject to all objects in the list. // And finally sends a Detroy_Object to itself. Procedure DestroyObject Integer iC hoID For iC From 0 To (Item_Count(Self)) Get Value item iC to hoID If (hoID) Begin Send DestroyObject to hoID End End Send Destroy_Object End_Procedure Function BuffNextLine Returns String String sRet Delegate Get BuffNextLine to sRet Function_Return sRet End_Function Function BuffPreviousLine Returns String String sRet Delegate Get BuffPreviousLine to sRet Function_Return sRet End_Function Procedure Set BuffCurrentLine Integer iL Delegate Set BuffCurrentLine to iL End_Procedure Function BuffCurrentLine Returns Integer Integer iL Delegate Get BuffCurrentLine to iL Function_Return iL End_Function // Creates an element of the object list... Function CreateElement Returns Integer Integer hoID Object oElement is a cCodeComponent Move Self to hoID End_Object Set Value item (Item_Count(Self)) to hoID Function_Return hoID End_Function // Deletes the last item. Procedure DoDeleteLastElement Integer hoID Get Value item (Item_Count(Self)-1) to hoID If (hoID) Begin Send Request_Destroy_Object to hoID End Send Delete_Item (Item_Count(Self)-1) End_Procedure // Checks if there is a public statement in the comment. Procedure DoCheckPublic String sStr Integer iPublicOnly Set piPublic to True Delegate Get piPublicOnly to iPublicOnly If (iPublicOnly = True) Begin If (Lowercase(sStr) contains "") Begin Set piPublic to False End If (Lowercase(sStr) contains "visibility=private" or Lowercase(sStr) contains "nodoc=true") Begin Set piPublic to False End If (Lowercase(sStr) contains "visibility=public") Begin Set piPublic to True End End // Else Set piPublic To True End_Procedure // ToDo: This procedure should be changed so that Meta Data is also read ****** // // Searches upwards for Lines with "//" on the left side // and read this comments into the given ComponentID Procedure ReadComments Integer hoID String sLineE Integer iEnde iLine iPos String sLine sComp sTmp Set piPublic to False Move (sComp + String(Character(47)) + String(Character(47))) to sComp Move (Trim(sLineE)) to sLineE Move (Pos(sComp, sLineE)) to iPos If (iPos = 0) Begin Move ((Left(sLineE, 1)) = "{") to iPos End If (iPos > 0) Begin If (Left(sLineE, 1) <> "{") Begin Move (Right(sLineE,Length(sLineE)-iPos)) to sTmp End Else Begin Move sLineE to sTmp End Send DoCheckPublic sTmp Send AddComment To hoID sTmp Move (Left(sLineE,iPos-1)) to sLineE End Get BuffCurrentLine to iLine Repeat Get BuffPreviousLine to sLine Move (Trim(sLine)) to sLine If (SeqEof = True) ; Move 1 to iEnde If (Left(sLine, 2) <> sComp) Begin Move 1 to iEnde End Else Begin Send DoCheckPublic sLine Send AddComment to hoID sLine End Until (iEnde) Set BuffCurrentLine to iLine Procedure_Return sLineE End_Procedure // Checks if a Tag occurs on the left... Function CheckTagLeft String sLine String sTag Returns Integer Integer iL Move (Uppercase(sTag)) to sTag Move (Uppercase(sLine)) to sLine Move (LTrim(sLine)) to sLine Move (Length(sTag)) To iL If (sLine contains "CONSTRUCT_OBJECT") Begin Function_Return 0 End If (Left(sLine,iL) = sTag) Begin Function_Return 1 End Else Begin Function_Return 0 End End_Function // For later overwrite... Procedure OnParsing String sLine Integer hoID End_Procedure Procedure OnStartTag String sLine Integer hoID End_Procedure Procedure OnEndTag String sLine Integer hoID End_Procedure Procedure WriteElement Integer iC hoID For iC from 0 to (Item_Count(Self)-1) Get Value item iC to hoID If (hoID) Begin Send WriteElement to hoID End End End_Procedure Procedure WriteElementHTML Integer iC hoID For iC from 0 to (Item_Count(Self)-1) Get Value item iC to hoID If (hoID) Begin Send WriteElementHTML to hoID End End End_Procedure // Tries to run a given line (for known tags) // Returns true if known or false if not Function ParseLine String sLine Returns Integer Integer hoID iLines iEnde iMaxLines String sStart sEnde // Change by Nils G. Svedmyr 15th of March, 2008. // Use property to restrict the number of rows read when code is parsed. // It used to be hardcoded to 1000. The class property has been set to 10000. Get piMaxLines to iMaxLines Get psParseStartTag to sStart Get psParseEndTag to sEnde If (CheckTagLeft(Self, sLine, sStart)) Begin Move (CreateElement(Self)) to hoID // Creates an Element Get Msg_ReadComments hoID sLine to sLine // Reads the CommentLines into it Send onStartTag sLine hoID // To overwrite If (sEnde <> "") Begin Repeat Get BuffNextLine to sLine If (CheckTagLeft(Self, sLine, sEnde)) Begin Send onEndTag sLine hoID Move 1 To iEnde End If (SeqEof = True) ; Move 1 to iEnde If (Not(iEnde)) Begin Send onParsing sLine hoID Increment iLines End If (iLines = iMaxLines) Begin Move 1 to iEnde End Until (iEnde) Set piCodeLines of hoID to iLines End If (not(piPublic(Self)) and psParseStartTag(Self) <> "Class") Begin Send DoDeleteLastElement End Function_Return True // Line was parsed End Else ; Function_Return False // Line wasn't parsed End_Function End_Class // Containes a list of Procedures Class cProcedureList Is a cCodeComponentList Procedure Construct_Object Forward Send Construct_Object Set psParseStartTag to "Procedure " Set psParseEndTag to "End_Procedure" End_Procedure // Creates an element of the object list... Function CreateElement Returns Integer Integer hoID Object oElement is a cProcedureComponent Move Self to hoID End_Object Set Value item (Item_Count(Self)) to hoID Function_Return hoID End_Function // Fills in the start tag informations Procedure OnStartTag String sLine Integer hoID Integer iStart iC String sPara Send ParseString to hoID sLine If (Uppercase(ParsedStringPart(hoID, 1)) <> "SET") Begin Move 1 to iStart End Else Begin Move 2 to iStart End If (iStart = 2) Begin Set psType of hoID to "Set" End Set psName of hoID to (ParsedStringPart(hoID,iStart)) For iC from (iStart + 1) to (ParsedStringCount(hoID)-1) Append sPara " " (ParsedStringPart(hoID,iC)) End Set psRest of hoID to sPara End_Procedure End_Class // Containes a list of Functions Class cFunctionList Is a cCodeComponentList Procedure Construct_Object Forward Send Construct_Object Set psParseStartTag to "Function " Set psParseEndTag to "End_Function" End_Procedure // Creates an element of the object list... Function CreateElement Returns Integer Integer hoID Object oElement is a cFunctionComponent Move Self to hoID End_Object Set Value item (Item_Count(Self)) to hoID Function_Return hoID End_Function // Fills in the start tag informations Procedure OnStartTag String sLine Integer hoID Integer iC String sPara Send ParseString to hoID sLine Set psName of hoID to (ParsedStringPart(hoID,1)) For iC from 2 to (ParsedStringCount(hoID)-1) Move (sPara + " " + (ParsedStringPart(hoID,iC))) to sPara End Set psRest of hoID to sPara End_Procedure End_Class // Containes a list of properties Class cPropertyList Is a cCodeComponentList Procedure Construct_Object Forward Send Construct_Object Set psParseStartTag to "Property " Set psParseEndTag to "" End_Procedure // Creates an element of the object list... Function CreateElement Returns Integer Integer hoID Object oElement is a cPropertyComponent Move Self to hoID End_Object Set Value item (Item_Count(Self)) to hoID Function_Return hoID End_Function // Fills in the start tag informations Procedure OnStartTag String sLine Integer hoID Send ParseString to hoID sLine Set psName of hoID to (ParsedStringPart(hoID,2)) Set psType of hoID to (ParsedStringPart(hoID,1)) End_Procedure End_Class // Containes all Information, Procedures, Functions and Properties of a Class Class cClassComponent is a cCodeComponent Procedure Construct_Object Forward Send Construct_Object Object oProcedureList is a cProcedureList // List of all procedures End_Object Object oFunctionList is a cFunctionList // List of all functions End_Object Object oPropertyList is a cPropertyList // List of all properties End_Object Object oBaseClassesLNKs Is an Array // Links to classes which are found! End_Object Object oBaseClasses is an Array // Item 0 it the base_class End_Object End_Procedure // Destroys the object and all children. Procedure DestroyObject Send DestroyObject to (oProcedureList(Self)) Send DestroyObject to (oFunctionList(Self)) Send DestroyObject to (oPropertyList(Self)) Send Destroy_Object to (oBaseClasses(Self)) Forward Send DestroyObject End_Procedure // Tries to get links to the BaseClasses // The given object_id is a cFileClassList object, which is able to resolve a class. // If already parsed! Procedure ResolveClassNames Integer hoID Integer iC String sClass sLink For iC from 0 to (Item_Count(oBaseClasses(Self))-1) Get Value of (oBaseClasses(Self)) item iC to sClass Get ResolveClass of hoID sClass to sLink Set Value of (oBaseClassesLNKs(Self)) item iC to sLink End End_Procedure // Adds a base class // first is the real base_class all further calls // are done because of IMPORT_CLASS_PROTOCOL commands. Procedure AddBaseClass String sClassName Set Value of (oBaseClasses(Self)) item (Item_Count(oBaseClasses(Self))) to sClassName End_Procedure // For an easier access to the classname for the subelements, // like procedures, functions, properties. Function ClassName Returns String Function_Return (psName(Self)) End_Function Procedure WriteElement Forward Send WriteElement Send WriteElement to (oPropertyList(Self)) Send WriteElement to (oProcedureList(Self)) Send WriteElement to (oFunctionList(Self)) End_Procedure // Checks if a link to a class is known and the it creates a ref= // if not only the classname is returned. Function BaseClassValueHTML Integer iNr Returns String String sValue sLink sRet c34 Move (Character(34)) to c34 Get value of (oBaseClasses(Self)) item iNr to sValue Get value of (oBaseClassesLNKs(Self)) item iNr to sLink If (sLink <> "") Begin Move ("" + sValue + "") to sRet Function_Return sRet End Else Begin Function_Return sValue End End_Function Procedure WriteElementHTML Integer iC hoID iCount String c34 sName sClassName sRefName sSource Get psSourceFile to sSource Get ClassName to sClassName Move (Character(34)) To c34 Writeln "
" Writeln "

Class " (psName(Self)) "

" //" Write "Source: " (Uppercase(ParseFileName(sSource))) "
" Write "Baseclass: " (BaseClassValueHTML(Self,0)) "
" If (Item_Count(oBaseClasses(Self)) > 1) Begin Writeln "Imported Mixins: " End For iC From 1 To (Item_Count(oBaseClasses(Self))-1) Writeln (BaseClassValueHTML(Self,iC)) " " End Writeln "

" Send WriteCommentsHTML If (Item_Count(oPropertyList(Self)) > 0) Begin Writeln "

Properties

" Writeln "" End If (Item_Count(oProcedureList(Self)) > 0) Begin Writeln "

Procedures

" Writeln "" End If (Item_Count(oFunctionList(Self)) > 0) Begin Writeln "

Functions

" Writeln "" End Send WriteElementHTML to (oPropertyList(Self)) Send WriteElementHTML to (oProcedureList(Self)) Send WriteElementHTML to (oFunctionList(Self)) End_Procedure End_Class // Containes a list of Classes Class cClassList is a cCodeComponentList Procedure Construct_Object Forward Send Construct_Object Set psParseStartTag to "Class" Set psParseEndTag to "End_Class" End_Procedure Procedure WriteElementHTML Integer iC hoID String c34 sName Move (Character(34)) to c34 Writeln "

Class List

" Writeln "" Forward Send WriteElementHTML End_Procedure // Creates an element of the object list... Function CreateElement Returns Integer Integer hoID Object oElement is a cClassComponent Move Self to hoID End_Object Set Value item (Item_Count(Self)) to hoID Function_Return hoID End_Function // Fills in the start tag informations Procedure OnStartTag String sLine Integer hoID Send ParseString to hoID sLine Set psName of hoID to (ParsedStringPart(hoID,1)) Send AddBaseClass to hoID (ParsedStringPart(hoID,4)) // Class XXX is a BaseClass End_Procedure // Is called for all lines between "Class" end "End_Class" // and every line is tried to be parsed either by ProcedueList, FunctionList // or PropertyList. // Parses subcomponents Procedure OnParsing String sLine Integer hoID Integer iRet //123456789012345678901 String sTmp Move (Left(Trim(Uppercase(sLine)),21)) to sTmp If (sTmp = "IMPORT_CLASS_PROTOCOL") Begin Send ParseString to hoID sLine Send AddBaseClass to hoID (ParsedStringPart(hoID,1)) // IMPORT_CLASS_PROTOCOL ClassName Move 1 to iRet End If (not(iRet)) Begin Get ParseLine of (oProcedureList(hoID)) sLine to iRet End If (not(iRet)) Begin Get ParseLine of (oFunctionList(hoID)) sLine to iRet End If (not(iRet)) Begin Get ParseLine of (oPropertyList(hoID)) sLine to iRet End End_Procedure End_Class // Reads all Classes and their subcomponets. // First I had the idea to read all packeges into one of these objects // to get (one file) and a complete class list, but I think such a large html // file would be rather slow to load. So I'd prefer to create one object (means one file) // for each read source file. Class cCodeSpy is an Array Procedure Construct_Object Forward Send Construct_Object Set Delegation_Mode to Delegate_To_Parent Object oDependencies is an Array End_Object Object oHeader Is a cCodeComponent End_Object Object oClassList Is a cClassList End_Object // Object oGlobalProcedures is a cProcedureList // Don't want to support this now. // End_Object // Object oGlobalFunctions is a cFunctionList // End_Object Property Integer BuffCurrentLine -1 Property String psSourceFile "" Property Integer piScanDependencies False End_Procedure // Clears all entries. Procedure DestroyObject Send Destroy_Object to (oDependencies(Self)) Send DestroyObject to (oHeader(Self)) Send DestroyObject to (oClassList(Self)) Forward Send DestroyObject End_Procedure // Registers all Classes in the embedded list. Procedure RegisterAllClasses Integer iC hoID String sSource Get psSourceFile to sSource For iC from 0 to (Item_Count(oClassList(Self))) Get Value of (oClassList(Self)) item iC to hoID If (hoID) Begin Send RegisterClass (ClassName(hoID)) sSource End End End_Procedure // Starts to read the data out of the buffer. // Resets BuffCurrentLine and SEQEOF. // Which I also use during this kind of virtual reading. Procedure BuffInput Set BuffCurrentLine to -1 Move False to SeqEof End_Procedure // Retrieves the next line of the buffer. Function BuffNextLine Returns String Set BuffCurrentLine to (BuffCurrentLine(Self)+1) If (BuffCurrentLine(Self) >= Item_Count(Self)) Begin Move True to SeqEof Function_Return "" End Function_Return (Value(Self, BuffCurrentLine(Self))) End_Function // Retrieves the previous line of the buffer. Function BuffPreviousLine Returns String Set BuffCurrentLine to (BuffCurrentLine(Self)-1) If (BuffCurrentLine(Self) < 0) Begin Move True to SeqEof Function_Return "" End Function_Return (Value(Self, BuffCurrentLine(Self))) End_Function // Write's the header of the created htmlfile. Procedure WriteHeaderHTML Integer iH iM is String sDate sHeaderInfo c34 Move (Character(34)) to c34 Sysdate sDate iH iM is Move (" [ Header and license information ]") to sHeaderInfo Writeln "Created " sDate " " (Right(Append("0",iH),2)) ":" (Right(Append("0",iM),2)) ":" (Right(Append("0",is),2)) " by " (Network_User_Name(Desktop)) " on " (ComputerName(Desktop)) "" sHeaderInfo "
" Writeln "
" End_Procedure // Writes the class-list to a file (HTML formated) Procedure WriteHTML String sFile String c34 If (Item_Count(oClassList(Self)) = 0) Begin Procedure_Return // Does nothing if no classes entered! End Move (Character(34)) to c34 Direct_Output sFile Writeln "" Writeln "" Writeln "" Writeln "" Writeln "" Send WriteHeaderHTML Send WriteElementHTML to (oClassList(Self)) Writeln "

Header and license information

" Send WriteCommentsHTMLNormal to (oHeader(Self)) Writeln "" Writeln "" Close_Output End_Procedure // Reads a source file into the buffer. Procedure FillBuffer String sFile Integer iHeaderEnde String sL sComp Set psSourceFile to sFile Append sComp (Character(47)) (Character(47)) Direct_Input sFile Repeat ReadLn sL If (not(SeqEof)) Begin If (Left(Uppercase(Ltrim(sL)),2) <> sComp) Begin Move 1 to iHeaderEnde End If (not(iHeaderEnde)) Begin Send AddComment to (oHeader(Self)) sL End Set Value item (Item_Count(Self)) to sL End Until (SeqEof = True) Close_Input End_Procedure // Loads a file and parses it. Procedure ParseSourceFile String sFile Send FillBuffer sFile Send ParseBuffer End_Procedure // Parses lines outside of classes. // At the moment only "Use" statements are scanned. Function ParseLine String sLine Returns Integer String sFile sLine2 Integer iScanDependencies Get piScanDependencies to iScanDependencies Move (Trim(sLine)) to sLine Move (Uppercase(sLine)) to sLine2 If (iScanDependencies and Left(sLine2, 4) = "USE ") Begin // Only if a use statement... Move (Right(sLine,Length(sLine)-4)) to sFile // Only packages are scanned. If (sFile contains " ") Begin Move (Left(sFile,Pos(" ", sFile) - 1)) to sFile End If (sFile contains ".") Begin // Neither it is a "File.PKG" If (sFile contains ".PKG") Begin Delegate Send RunParseFile sFile // or no extention which is also PKG. Function_Return 1 End End Else Begin Delegate Send RunParseFile (Append(sFile,".PKG")) Function_Return 1 End End Function_Return 0 End_Function // Parses the buffer, in which the source file was read before and creates the class-list. Procedure ParseBuffer Integer iRet String sL Send BuffInput Repeat Get BuffNextLine to sL If (SeqEof = False) Begin Get ParseLine sL to iRet If (not(iRet)) Begin Get ParseLine of (oClassList(Self)) sL to iRet End End Until (SeqEof = True) End_Procedure Procedure ResolveClassNames Integer hoID Broadcast Recursive Send ResolveClassNames hoID End_Procedure End_Class Class cSortSet is a Set Procedure Construct_Object Forward Send Construct_Object // All objects which are stored in this array get also switched the items. Object oAdditionalObjects Is an Array End_Object Property Integer piItemSwitched 0 Property Integer piDescending False Property Integer piCaseSensitive False End_Procedure // Adds an addtional object. Procedure AddAdditionalObject Integer hoID Set Value of (oAdditionalObjects(Self)) item (Item_Count(oAdditionalObjects(Self))) to hoID End_Procedure // Checks is switching is neccessary. Function NeedToSwitch Integer iItem Returns Integer Integer iSwitch String sI1 sI2 Get Value item iItem to sI1 Get Value item (iItem+1) to sI2 If (Not(piCaseSensitive(Self))) Begin Move (Uppercase(sI1)) to sI1 Move (Uppercase(sI2)) to sI2 End If (piDescending(Self)) Begin If (sI2 > sI1) Begin Move 1 to iSwitch End End Else Begin If (sI2 < sI1) Begin Move 1 to iSwitch End End Function_Return iSwitch End_Function // Switches Item iNr and Item (iNr+1) // Items in addtional objects are also switched. Procedure SwitchItems Integer iItem Integer iC hoID String sI1 Set piItemSwitched to True For iC from -1 to (Item_Count(oAdditionalObjects(Self))-1) If (iC < 0) Begin Move Self to hoID End Else Begin Get value of (oAdditionalObjects(Self)) item iC to hoID End If (hoID) Begin Get Value of hoID item iItem to sI1 Set Value of hoID item iItem to (Value(hoID,iItem+1)) Set Value of hoID item (iItem+1) to sI1 End End End_Procedure Procedure SortItems Integer iC iCount iZ Get Item_Count to iCount Repeat Increment iZ Set piItemSwitched to False For iC from 0 to (iCount - 2) If (NeedToSwitch(Self,iC)) Begin Send SwitchItems iC End End Until (Not(piItemSwitched(Self))) End_Procedure // Resets the object. Procedure DoInit Send Delete_Data End_Procedure End_Class // Use this as an simple object list. Class cClassGrouper is a cCodeComponentList Procedure Construct_Object Forward Send Construct_Object Object oGroupNames Is a cSortSet Send AddAdditionalObject (Parent(Self)) End_Object End_Procedure // Adds an Entry to the (a) group. Procedure AddEntry String sGRP String sClass Integer iC hoID Move (Trim(sGrp)) to sGrp If (sGRP = "") Begin Move "Not Group assigned (Can be done on the 'Maintain Classes tabpage')" to sGrp End Get Find_Element of (oGroupNames(Self)) sGRP to iC If (iC < 0) Begin Move (CreateElement(Self)) to hoID Get Item_Count of (oGroupNames(Self)) to iC Set Value of (oGroupNames(Self)) item iC to sGrp End Get Value item iC to hoID Set psName of hoID to sGRP Set Value of hoID item (Item_Count(hoID)) to sClass End_Procedure End_Class // To link to classes which aren't in the same HTML file its neccessary to // hold a class list where all class name and the fitting html files are kept. Class cFileClassList is an Array Procedure Construct_Object Integer hoID hoID2 Object oSourceFiles Is a Set Move Self to hoID End_Object Object oRests is an Array Move Self to hoID2 End_Object Object oClassNames is a cSortSet Send AddAdditionalObject hoId Send AddAdditionalObject hoId2 End_Object Property String psFileName "ClassReference.lst" // Reads and writes to this file Property String psDirectory "" // in this dir. End_Procedure // Creates the full file path. Function PathFileName Returns String String sFile sPath Get psDirectory to sPath Move (Trim(sPath)) to sPath Get vFolderFormat sPath to sPath Move (sPath + psFileName(Self)) to sFile Function_Return sFile End_Function // Saves the Classlist into HTML format for easier access. // Writes the classreference.lst & Classreference.htm to disk. Procedure WriteHTML String sFile sLink c34 sStr sGrp sPath sExt Integer iC hoID hoID2 iC2 Object oGrp is a cClassGrouper Move Self to hoID End_Object For iC from 0 to (Item_Count(oClassNames(Self))-1) Get ResolveClassNr iC to sLink Get Value of (oRests(Self)) item iC to sGrp Move "" to sStr Move ("
  • " + (Value(oClassNames(Self),iC)) + "

    • ") to sStr Send AddEntry to hoID sGrp sStr End Send SortItems to (oGroupNames(hoID)) Move (Character(34)) to c34 Get PathFileName to sFile Get ParseFolderName sFile to sPath Get ParseFileExtension sFile to sExt If (Left(sFile,1) = ".") Begin Move (Replace(".",sFile,"@@@")) to sFile End Move (Replace(sExt, sFile, "htm")) to sFile If (Left(sFile,3) = "@@@") Begin Move (Replace("@@@",sFile,".")) to sFile End Direct_Output sFile Writeln "" Writeln "" Writeln "" Writeln "" Writeln "" Writeln "" Writeln "

    Classes

    " For iC From 0 To (Item_Count(hoID)-1) Get Value of hoID item iC to hoID2 Writeln "

    " (psName(hoID2)) "

    " Writeln "
      " For iC2 From 0 To (Item_Count(hoID2)-1) Writeln (Value(hoID2,iC2)) End Writeln "
    " End Writeln "    " Writeln "" Writeln "" Close_Output Send DestroyObject To hoID End_Procedure // Sends a given Msg for every class entry. Procedure EnumClasses Integer iMsg Integer hoDest Integer iC String sCls sSrc sRest If (not(hoDest)) Begin Procedure_Return End If (not(iMsg)) Begin Procedure_Return End For iC from 0 to (Item_Count(oClassNames(Self))-1) Get Value of (oClassNames(Self)) item iC to sCls Get Value of (oSourceFiles(Self)) item iC to sSrc Get Value of (oRests(Self)) item iC to sRest Send iMsg to hoDest sCls sSrc sRest End End_Procedure // Destroys the object and its children. Procedure DoInit Send Delete_Data to (oClassNames(Self)) Send DoInit to (oClassNames(Self)) Send Delete_Data to (oSourceFiles(Self)) Send Delete_Data to (oRests(Self)) End_Procedure // Tries to resolve a class no. (Internal use) Function ResolveClassNr Integer iNr Returns String Integer iC String sSource sClass Get Value of (oClassNames(Self)) item iNr to sClass Get Value of (oSourceFiles(Self)) item iNr to sSource // move (FileFromPath(sSource)) to sSource Move (Append(Left(sSource,Pos(".",sSource)),"htm")) to sSource Move (sSource + "#" + "Ref_" + String(sClass)) to sSource Function_Return sSource End_Function // Tries to resolve a class name. Function ResolveClass String sClass Returns String Integer iC String sSource Get Find_Element of (oClassNames(Self)) sClass to iC If (iC >= 0) Begin Function_Return (ResolveClassNr(Self,iC)) End Else Begin Function_Return "" // Class not known. End End_Function // Reads all classes and their source files into the object // out of psFileName. Procedure ReadClasses String sFile sClass sSource sRest Send Delete_Data to (oClassNames(Self)) Send Delete_Data to (oSourceFiles(Self)) Get PathFileName to sFile Direct_Input sFile Repeat Readln sClass sSource sRest If (SeqEof = False) Begin Send RegisterClass sClass sSource sRest End Until (SeqEof = True) Close_Input End_Procedure // Writes all stores classes and their infos into // psFileName. Procedure WriteClasses Integer iC String sFile sClass sSource sRest Get PathFileName to sFile Send SortItems to (oClassNames(Self)) Direct_Output sFile For iC from 0 to (Item_Count(oClassNames(Self))-1) Get Value of (oClassNames(Self)) item iC to sClass Get Value of (oSourceFiles(Self)) item iC to sSource Get Value of (oRests(Self)) item iC to sRest Writeln sClass "," sSource "," sRest End Close_Output Send WriteHTML End_Procedure // Creates an entry to the class list and checks before // if an entry for this class already exists, if so // only the SourceFile is changed for the old entry. Procedure RegisterClass String sClass String sSource String sRest Integer iC Move (Trim(sClass)) to sClass Move (Trim(sSource)) to sSource If (Trim(sClass) = "") Begin Procedure_Return End Get Find_Element of (oClassNames(Self)) sClass to iC If (iC < 0) Begin Get Item_Count of (oClassNames(Self)) to iC End Set Value of (oClassNames(Self)) item iC to sClass Set Value of (oSourceFiles(Self)) item iC to sSource If (NUM_Arguments > 2) Begin Set Value of (oRests(Self)) item iC to sRest End End_Procedure End_Class // This class creates a cCopySpy object for every file it should parse. // So it is a simple object list with a special interface. // This is done to allow to scan for dependencies. ("Use PackageFile.pkg") // So during every scan a detected "Use" statement will cause a "Delegate send RunParseFile ..." // to parse that Use'd file too. Class cMultiFileCodeSpy is an Array Procedure Construct_Object Forward Send Construct_Object Object oFileNames Is a Set // FileNames are stored so that one file is only parsed once! End_Object Object oCodeSpyIDs Is an Array // Ids of all cCodeSpy objects End_Object Object oFileClassList Is a cFileClassList End_Object Property Integer piScanDependencies True Property String psDirectoryInt "" // The Outputdirectory Property Integer piPublicOnly True End_Procedure Procedure Set psDirectory String sDir Set psDirectoryInt to sDir Set psDirectory of (oFileClassList(Self)) to sDir End_Procedure Function psDirectory Returns String Function_Return (psDirectoryInt(Self)) End_Function Procedure DoInit Integer iC hoID For iC from 0 to (Item_Count(oCodeSpyIDs(Self))-1) Get Value of (oCodeSpyIDs(Self)) item iC to hoID If (hoID <> 0) Begin Send DestroyObject to hoID End End Send DoInit to (oFileClassList(Self)) Send Delete_Data to (oCodeSpyIDs(Self)) Send Delete_Data to (oFileNames(Self)) Set psDirectory of (oFileClassList(Self)) to (psDirectory(Self)) Send ReadClasses To (oFileClassList(Self)) End_Procedure Procedure RegisterAllClasses Integer iC hoID For iC from 0 to (Item_Count(oCodeSpyIDs(Self))-1) Get Value of (oCodeSpyIDs(Self)) item iC to hoID If (hoID <> 0) Begin Send RegisterAllClasses to hoID End End End_Procedure Procedure RegisterClass String sClassName String sFile Send RegisterClass to (oFileClassList(Self)) sClassName (ParseFileName(sFile)) End_Procedure // Creates a cCodeSpy object and parses the given // file in it. Procedure RunParseFile String sFile Integer hoID iRet iSeqeof Move (SeqEof) to iSeqeof Get Find_Element of (oFileNames(Self)) sFile to iRet If (iRet >= 0) Begin Procedure_Return // Skip if already parsed! End Send Add_Element to (oFileNames(Self)) sFile Object oCodeSpy is a cCodeSpy Move Self to hoID Set piScanDependencies to (piScanDependencies(Parent(Self))) End_Object Set Value of (oCodeSpyIDs(Self)) item (Item_Count(oCodeSpyIDs(Self))) to hoID Send ParseSourceFile to hoID sFile Move iSeqeof to SeqEof End_Procedure Procedure WriteAboutFile Writeln "" Writeln "" Writeln "

    CodeSpy 2014.0

    " Writeln "

    created by

    " Writeln "

    Michael Kurz
    " Writeln "Todd Forsberg, Nils G. Svedmyr" Writeln "

    " Writeln "" Writeln "" End_Procedure // Writes the classreference.lst & Classreference.htm to disk. Procedure WriteHTML String sFile sDir sExt Integer hoID iC Get psDirectory to sDir Move (Trim(sDir)) to sDir Get vFolderFormat sDir to sDir Send RegisterAllClasses Send WriteClasses to (oFileClassList(Self)) For iC from 0 to (Item_Count(oCodeSpyIDs(Self))-1) Get Value of (oCodeSpyIDs(Self)) item iC to hoID If (hoID) Begin Get psSourceFile of hoID to sFile Move (Trim(sFile)) to sFile Get ParseFileName sFile to sFile If (sFile contains ".") Begin Get ParseFileExtension sFile to sExt Move (Replace(sExt, sFile, "htm")) to sFile End Else Begin Move (sFile + ".htm") to sFile End Send ResolveClassNames to hoID (oFileClassList(Self)) Send WriteHTML to hoID (Append(sDir,sFile)) End End End_Procedure End_Class