//***************************************************************************************** // Created 2000 Michael Kurz // // $FileName : CodeSpy // $ProjectName : Analyse VDF code (class definitions) // $Author : Michael Kurz // $Created : 12-08-2000 @ 00:10 // // This code can be used in any apllication for free, but must not be sold in any way. // 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 // 26.9.2014 Major rewrite of the user interface by Nils G. Svedmyr. nils.svedmyr@rdctools.com // Also replaced most of the legacy code with more contemporary DataFlex code. // //TH-RevisionEnd //***************************************************************************************** Use Set.pkg Use Windows.pkg Use DLL.pkg Use vWin32fh.pkg Define CS_COMMENT_START for (Character(47) + Character(47)) Define CS_QUOTE for (Character(34)) // 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 that has both path and filename. Function PathFromPath Global String sPath Returns String Get ParseFolderName sPath to sPath Get RTrimBackSlash sPath to sPath Function_Return sPath End_Function // Parses a filename from a string that has 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 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 Desktop Returns String String sName Get_Environment "COMPUTERNAME" to sName Function_Return sName End_Function Function Network_User_Name Desktop 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 // Is the base class for all source components // Can be Class, Procedure, Property, Function // Used for subclassing. 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_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 // An 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 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 + "" + sEmail + "") 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_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 sClassName sName 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 sClassName sName 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 sClassName sName String sType Delegate Get ClassName to sClassName Get psName to sName Get psType to sType Writeln "" sName " - Property " sType "
" 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 piPublicOnly 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 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 Get Create u_cCodeComponent to hoID Set Value (Item_Count(Self)) to hoID Function_Return hoID End_Function // Deletes the last item. Procedure DoDeleteLastElement Integer hoID Get Value (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 Delegate Get piPublicOnly to iPublicOnly If (iPublicOnly) Begin If (Lowercase(sStr) contains "") Begin Set piPublicOnly to True End End // If iPublicOnly If "" In (Lowercase(sStr)) Set piPublicOnly to True Else Begin Set piPublicOnly to True End End_Procedure // ******* 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 piPublicOnly to False Append sComp CS_COMMENT_START Move (Trim(sLineE)) to sLineE Move (Pos(sComp,sLineE)) to iPos If (iPos > 0) Begin Move (Right(sLineE, Length(sLineE) -iPos)) to sTmp 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 iItems Get Item_Count to iItems Decrement iItems For iC from 0 to iItems Get Value iC to hoID If (hoID) Begin Send WriteElement to hoID End End End_Procedure Procedure WriteElementHTML Integer iC hoID iItems Get Item_Count to iItems For iC from 0 to iItems Get value 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 Boolean bEnds Integer hoID iLines 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 Move False to bEnds 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 True To bEnds End If (SeqEof = True) Begin Move True to bEnds End If (Not(bEnds)) Begin Send onParsing sLine hoID Increment iLines End If (iLines = iMaxLines) Begin Move True to bEnds End Until (bEnds) Set piCodeLines of hoID to iLines End If (not(piPublicOnly(Self))) Begin // If (psParseStartTag(Self) <> "Class") Begin If (psParseStartTag(Self) <> sStart) Begin Send DoDeleteLastElement End End // If not (piPublicOnly(Self)) If (psParseStartTag(Self)) Ne "Class" Send DoDeleteLastElement 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 Get Create u_cProcedureComponent to hoID Set Value (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 iItems 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)) Get ParsedStringCount of hoID to iItems Decrement iItems For iC from (iStart + 1) to iItems 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 Get Create u_cFunctionComponent to hoID Set Value (Item_Count(Self)) to hoID Function_Return hoID End_Function // Fills in the start tag informations Procedure OnStartTag String sLine Integer hoID Integer iC iItems String sPara Send ParseString to hoID sLine Set psName of hoID to (ParsedStringPart(hoID, 1)) Get ParsedStringCount of hoID to iItems Decrement iItems For iC from 2 to iItems Append sPara " " (ParsedStringPart(hoID,iC)) 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 Get Create u_cPropertyComponent to hoID Set Value (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 // 0 is the base_class End_Object // are imported (IMPORT_CLASS_PROTOCOL) 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 iItems String sClass sLink Get Item_Count of oBaseClasses to iItems Decrement iItems For iC from 0 to iItems Get Value of (oBaseClasses(Self)) iC to sClass Get ResolveClass of hoID sClass to sLink Set Value of (oBaseClassesLNKs(Self)) 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_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 Get Value of (oBaseClasses(Self)) iNr to sValue Get Value of (oBaseClassesLNKs(Self)) iNr to sLink If (sLink <> "") Begin Append sRet "" sValue "" Function_Return sRet End Else Begin Function_Return sValue End End_Function Procedure WriteElementHTML Integer iC hoID iItems String sName sClassName sRefName sSource Get psSourceFile to sSource Get ClassName to sClassName 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 Get Item_Count of oBaseClasses to iItems Decrement iItems For iC from 1 to iItems Writeln (BaseClassValueHTML(Self,iC)) " " End Writeln "

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

Properties

" Writeln "
    " End Get Item_Count of (oPropertyList(Self)) to iItems Decrement iItems For iC from 0 to iItems Get Value of (oPropertyList(Self)) iC to hoID If (hoID) Begin Get psName of hoID to sName Writeln "
  • " sName "
    • " End End If (Item_Count(oPropertyList(Self)) > 0) Begin Writeln "
" End If (Item_Count(oProcedureList(Self)) > 0) Begin Writeln "

Procedures

" Writeln "
    " End Get Item_Count of (oProcedureList(Self)) to iItems Decrement iItems For iC from 0 to iItems Get Value of (oProcedureList(Self)) iC to hoID If (hoID) Begin Get psName of hoID to sName Writeln "
  • " sName "
    • " End End If (Item_Count(oProcedureList(Self))) Begin Writeln "
" End If (Item_Count(oFunctionList(Self)) > 0) Begin Writeln "

Functions

" Writeln "
    " End Get Item_Count of (oFunctionList(Self)) to iItems Decrement iItems For iC from 0 to iItems Get Value of (oFunctionList(Self)) iC to hoID If (hoID) Begin Get psName of hoID to sName Writeln "
  • " sName "
    • " End End If (Item_Count(oFunctionList(Self)) > 0) Begin 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 iItems String sName Writeln "

Class List

" Writeln "
    " Get Item_Count to iItems Decrement iItems For iC from 0 to iItems Get Value iC to hoID If (hoID) Begin Get psName of hoID to sName Writeln "
  • " sName "
    • " End End Writeln "
" Forward Send WriteElementHTML End_Procedure // Creates an element of the object list... Function CreateElement Returns Integer Integer hoID Get Create u_cClassComponent to hoID Set Value (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 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 one 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 Property Integer BuffCurrentLine -1 Property String psSourceFile "" Property Integer piScanDependencies False End_Procedure // Clears all entries. Procedure DestroyObject Send Destroy_Object to oDependencies Send DestroyObject to oHeader Send DestroyObject to oClassList Forward Send DestroyObject End_Procedure // Registers all Classes in the embedded list. Procedure RegisterAllClasses Integer iC hoID iItems String sSource Get psSourceFile to sSource Get Item_Count of oClassList to iItems Decrement iItems For iC from 0 to iItems Get Value of oClassList 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 Integer iLine String sValue Get BuffCurrentLine To iLine Increment iLine Set BuffCurrentLine To iLine If (iLine >= Item_Count(Self)) Begin Move True to SeqEof Function_Return "" End Get Value iLine to sValue Function_Return sValue End_Function // Retrieves the previous line of the buffer. Function BuffPreviousLine Returns String Integer iLine String sValue Get BuffCurrentLine to iLine Decrement iLine Set BuffCurrentLine to iLine If (iLine < 0) Begin Move True to SeqEof Function_Return "" End Get Value iLine to sValue Function_Return sValue End_Function // Write's the header of the created htmlfile. Procedure WriteHeaderHTML Integer iH iM iSec String sDate sHeaderInfo Sysdate sDate iH iM iSec Append sHeaderInfo " [ Header and license information ]" Writeln "Created " sDate " " (Right(Append("0", iH), 2)) ":" (Right(Append("0", iM), 2)) ":" (Right(Append("0", iSec), 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 If (Item_Count(oClassList(Self)) = 0) Begin Procedure_Return // Does nothing if no classes entered! End Direct_Output sFile Writeln "" Writeln "" Writeln "" Writeln "" Writeln "" Send WriteHeaderHTML Send WriteElementHTML to oClassList Writeln "

Header and license information

" Send WriteCommentsHTMLNormal to oHeader Writeln "" Writeln "" Close_Output End_Procedure // Reads a source file into the buffer. Procedure FillBuffer String sFile Boolean bHeaderEnds String sL sComp Move False to bHeaderEnds Set psSourceFile to sFile Append sComp CS_COMMENT_START //(Character(47)) (Character(47)) Direct_Input sFile Repeat ReadLn sL If (not(SeqEof)) Begin If (Left(Uppercase(Ltrim(sL)), 2) <> sComp) Begin Move True to bHeaderEnds End If (not(bHeaderEnds)) Begin Send AddComment to (oHeader(Self)) sL End Set Value (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 are only "Use" statements scanned. Function ParseLine String sLine Returns Integer String sFile sLine2 Move (Trim(sLine)) to sLine Move (Uppercase(sLine)) to sLine2 If (piScanDependencies(Self)) Begin // Only if a use statement... If (Left(sLine2, 4) = "USE ") Begin 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 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_Count(oAdditionalObjects(Self))) to hoID End_Procedure // Checks if switching is neccessary. Function NeedToSwitch Integer iItem Returns Integer Integer iSwitch String sI1 sI2 Get Value iItem to sI1 Get Value (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 additional objects are also switched. Procedure SwitchItems Integer iItem Integer iC hoID iItems String sI1 Handle hoAdditionalObjects Set piItemSwitched to True Move (oAdditionalObjects(Self)) to hoAdditionalObjects Get Item_Count of hoAdditionalObjects to iItems Decrement iItems For iC from -1 to iItems If (iC < 0) Begin Move Self to hoID End Else Begin Get Value of hoAdditionalObjects iC to hoID End If (hoID) Begin Get Value of hoID iItem to sI1 Set Value of hoID iItem to (Value(hoID, iItem +1)) Set Value of hoID (iItem+1) to sI1 End End End_Procedure Procedure SortItems Integer iC iItems iZ Get Item_Count to iItems Repeat Increment iZ Set piItemSwitched to False For iC from 0 to (iItems - 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)) iC to sGrp End Get Value iC to hoID Set psName of hoID to sGRP Set Value of hoID (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 in. 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 sStr sGrp sPath sExt Integer iC hoID hoID2 iC2 iItems iItems2 Boolean bNewWindow Handle hoClassNames Get pbOpenNewWindow to bNewWindow // open classes in a new tab window in your browser Get Create u_cClassGrouper to hoID Move (oClassNames(Self)) to hoClassNames Get Item_Count of hoClassNames to iItems Decrement iItems For iC from 0 to iItems Get ResolveClassNr iC to sLink Get Value of (oRests(Self)) iC to sGrp Move "" to sStr If (bNewWindow) Begin Append sStr "
  • " (Value(hoClassNames, iC)) "

    • " End Else Begin Append sStr "
  • " (Value(hoClassNames, iC)) "

    • " End Send AddEntry to hoID sGrp sStr End Send SortItems to (oGroupNames(hoID)) 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

    " Get Item_Count of hoID to iItems Decrement iItems For iC from 0 to iItems Get Value of hoID iC to hoID2 Writeln "

    " (psName(hoID2)) "

    " Writeln "
      " Get Item_Count of hoID2 to iItems2 Decrement iItems2 For iC2 from 0 to iItems2 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)) iC to sCls Get value of (oSourceFiles(Self)) iC to sSrc Get value of (oRests(Self)) 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)) iNr to sClass Get Value of (oSourceFiles(Self)) iNr to sSource Move (Append(Left(sSource,Pos(".", sSource)), "htm")) to sSource Append sSource "#" "Ref_" sClass 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 iItems String sFile sClass sSource sRest Get PathFileName to sFile Send SortItems to (oClassNames(Self)) Direct_Output sFile Get Item_Count of (oClassNames(Self)) to iItems Decrement iItems For iC from 0 to iItems Get Value of (oClassNames(Self)) iC to sClass Get Value of (oSourceFiles(Self)) iC to sSource Get Value of (oRests(Self)) 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 (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)) iC to sClass Set Value of (oSourceFiles(Self)) iC to sSource If (NUM_Arguments > 2) Begin Set Value of (oRests(Self)) 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 Boolean pbScanDependencies True Property String psDirectoryInt "" // The Outputdirectory Property Boolean pbPublicOnly True Property Boolean pbOpenNewWindow 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 iItems Handle hoCodeSpyIDs Move (oCodeSpyIDs(Self)) to hoCodeSpyIDs Get Item_Count of hoCodeSpyIDs to iItems Decrement iItems for iC from 0 to iItems Get Value of hoCodeSpyIDs iC to hoID If (hoID <> 0) Begin Send DestroyObject to hoID End End Send DoInit to (oFileClassList(Self)) Send Delete_Data to hoCodeSpyIDs 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 iItems Handle hoCodeSpyIDs Move (oCodeSpyIDs(Self)) to hoCodeSpyIDs Get Item_Count of hoCodeSpyIDs to iItems Decrement iItems for iC from 0 to iItems Get Value of hoCodeSpyIDs 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_Count(oCodeSpyIDs(Self))) to hoID Send ParseSourceFile To hoID sFile Move iSeqeof to SeqEof End_Procedure Procedure WriteAboutFile Writeln "" Writeln "" Writeln "

    CodeSpy 2015.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 iItems Handle hoCodeSpyIDs hoFileClassList Get psDirectory to sDir Move (Trim(sDir)) to sDir Get vFolderFormat sDir to sDir Send RegisterAllClasses Move (oFileClassList(Self)) to hoFileClassList Send WriteClasses to hoFileClassList Move (oCodeSpyIDs(Self)) to hoCodeSpyIDs Get Item_Count of hoCodeSpyIDs to iItems Decrement iItems for iC from 0 to iItems Get Value of hoCodeSpyIDs 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 hoFileClassList Send WriteHTML to hoID (Append(sDir, sFile)) End End End_Procedure End_Class