+//-------------------------------------------------------------------------\r
+// win32.inc\r
+// This file contains DataFlex functions to provide wrappers around "Win32"\r
+// API calls. See win32.h for external function definitions.\r
+//\r
+// This file is to be included when using Win32 capabilities in df32func.mk\r
+//\r
+// Copyright (c) 2006-2009, glyn@8kb.co.uk\r
+// \r
+// df32func/win32.inc\r
+//-------------------------------------------------------------------------\r
+\r
+#IFDEF __win32_h__\r
+#ELSE\r
+ #INCLUDE win32.h\r
+#ENDIF\r
+\r
+//-------------------------------------------------------------------------\r
+// Functions\r
+//-------------------------------------------------------------------------\r
+\r
+// Takes both the high-order doubleword and low-order doubleword representing the date&time 2X32bit numbers\r
+// and returns as a string\r
+function convert_date_format global dword dwLowDateTime dword dwHighDateTime returns string\r
+ local string sftTime sSystemTime sFormattedTime sFormattedDate sLocalFileTime\r
+ local pointer lpsftTime lpsSystemTime lpsFormattedTime lpsFormattedDate lpsLocalFileTime\r
+ local integer iSuccess iLenCcTime iDataLength iLenCcDate\r
+\r
+ zerotype _FILETIME to sftTime\r
+ put dwLowDateTime to sftTime at FILETIME.dwLowDateTime\r
+ put dwHighDateTime to sftTime at FILETIME.dwHighDateTime\r
+ getaddress of sftTime to lpsftTime\r
+\r
+ zeroType _FILETIME to sLocalFileTime\r
+ getaddress of sLocalFileTime to lpsLocalFileTime\r
+\r
+ move (FileTimeToLocalFileTime(lpsftTime,lpsLocalFileTime)) to iSuccess\r
+ if (iSuccess <> 0) begin\r
+ zerotype _SYSTEMTIME to sSystemTime\r
+ getaddress of sSystemTime to lpsSystemTime\r
+\r
+ move (FileTimeToSystemTime(lpsLocalFileTime,lpsSystemTime)) to iSuccess\r
+ if (iSuccess <> 0) begin\r
+ zerostring 255 to sFormattedTime\r
+ getaddress of sFormattedTime to lpsFormattedTime\r
+ move (length(sFormattedTime)) to iLenCcTime\r
+ move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, lpsSystemTime, 0, lpsFormattedTime, iLenCcTime)) to iDataLength\r
+ \r
+ zerostring 255 To sFormattedDate\r
+ getaddress of sFormattedDate To lpsFormattedDate\r
+ move (length(sFormattedDate)) to iLenCcDate\r
+ move (GetDateFormat("LOCALE_USER_DEFAULT", 0, lpsSystemTime, 0, lpsFormattedDate, iLenCcDate)) to iDataLength\r
+ function_return (cstring (sFormattedDate) * cstring (sFormattedTime)) // return with terminating null char removed\r
+ end\r
+ end\r
+end_function\r
+\r
+// List directory takes a directory path and returns a file count-1\r
+// file listing information including size is put into 5 global arrays\r
+//\r
+// Returns an integer file_count-1, where count represents the number of files found in the directory.\r
+// I.e. If no files are found it will return -1, if one file is found it will return 0\r
+// If files are found, attributes of the files can be found in the following global arrays:\r
+// \r
+// Win32API_result1 - File Name\r
+// Win32API_result2 - File Size\r
+// Win32API_result3 - Modified Date\r
+// Win32API_result4 - Access Date\r
+// Win32API_result5 - Creation Date\r
+// \r
+function list_directory global string argv returns string\r
+ local string sPathName sWin32FindData sLine sLast sComment sFileName sModifiedDate sAccessDate sCreationDate k sLastFile\r
+ local integer l_01iResult iFileSize iFileCount\r
+ local pointer pT5 pT6\r
+ local handle hFile\r
+ local dword dwFileSizeHigh dwFileSizeLow dwHighDateTime dwLowDateTime\r
+\r
+ send delete_data to Win32API_result1\r
+ send delete_data to Win32API_result2\r
+ send delete_data to Win32API_result3\r
+ send delete_data to Win32API_result4\r
+ send delete_data to Win32API_result5\r
+\r
+ zerotype _WIN32_FIND_DATA to sWin32FindData\r
+ getaddress of sWin32FindData to pT5\r
+ move argv to sPathName\r
+ getaddress of sPathName to pT6\r
+ move (FindFirstFile(pT6, pT5)) to hFile\r
+ // if (hFile = -1) showln "Invalid file handle!"\r
+\r
+ move -1 to iFileCount\r
+ repeat \r
+ // FileName\r
+ getbuff_String from sWin32FindData at WIN32_FIND_DATA.cFileName to sFileName\r
+ if ((sFileName <> ".") and (sFileName <> "..") and (sFileName <> "")) begin\r
+ increment iFileCount\r
+\r
+ // FileSize\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeHigh to dwFileSizeHigh\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeLow to dwFileSizeLow\r
+ moveint ((dwFileSizeHigh*MaxDword)+dwFileSizeLow) to iFileSize\r
+\r
+ // File Modified Time\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteLowDateTime to dwLowDateTime\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteHighDateTime to dwHighDateTime\r
+ move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sModifiedDate\r
+ \r
+ // File Accessed Time\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessLowDateTime to dwLowDateTime\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessHighDateTime to dwHighDateTime\r
+ move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sAccessDate\r
+ \r
+ // File Creation Time\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationLowDateTime to dwLowDateTime\r
+ getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationHighDateTime to dwHighDateTime\r
+ move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sCreationDate\r
+\r
+ set array_value of (Win32API_result1(current_object)) item iFileCount to sFileName\r
+ set array_value of (Win32API_result2(current_object)) item iFileCount to iFileSize\r
+ set array_value of (Win32API_result3(current_object)) item iFileCount to sModifiedDate\r
+ set array_value of (Win32API_result4(current_object)) item iFileCount to sAccessDate\r
+ set array_value of (Win32API_result5(current_object)) item iFileCount to sCreationDate\r
+ end\r
+ zerotype _WIN32_FIND_DATA to sWin32FindData\r
+ move (FindNextFile(hFile, pT5)) to l_01iResult\r
+ until (l_01iResult = 0)\r
+ move (FindClose(hFile)) to l_01iResult\r
+\r
+ function_return iFileCount\r
+end_function\r
+\r
+// Sort a directory listing\r
+// argv = array to sort by 1-6, argv2 = array size\r
+// Returns the the data array size\r
+function sort_results global integer argv integer argv2 returns integer\r
+ local integer doneSort l_i l_j l_h l_tmpInt\r
+ local number l_tmpNum\r
+ local string l_tmpStr l_tmpStr2\r
+ local date l_tmpDate\r
+ \r
+ send delete_data to Win32API_sort\r
+ send delete_data to Win32API_sort1\r
+ send delete_data to Win32API_sort2\r
+ send delete_data to Win32API_sort3\r
+ send delete_data to Win32API_sort4\r
+ send delete_data to Win32API_sort5\r
+ send delete_data to Win32API_sort6\r
+\r
+ move 0 to doneSort\r
+ if ((argv < 1) or (argv > 5)) goto sorted\r
+\r
+ for l_i from 0 to argv2\r
+ if (argv = 1) get string_value of (Win32API_result1(current_object)) item l_i to l_tmpStr\r
+ if (argv = 2) get integer_value of (Win32API_result2(current_object)) item l_i to l_tmpInt\r
+ if (argv = 3) get string_value of (Win32API_result3(current_object)) item l_i to l_tmpStr\r
+ if (argv = 4) get string_value of (Win32API_result4(current_object)) item l_i to l_tmpStr\r
+ if (argv = 5) get string_value of (Win32API_result5(current_object)) item l_i to l_tmpStr\r
+\r
+ if (argv = 1) begin\r
+ if ((trim(l_tmpStr)) = "") move "NULL" to l_tmpStr\r
+ set array_value of (Win32API_sort(current_object)) item l_i to (string(lowercase(l_tmpStr)))\r
+ end\r
+ if (argv = 2) set array_value of (Win32API_sort(current_object)) item l_i to l_tmpInt\r
+ if (argv > 2) begin\r
+ calc ((((((integer(mid(l_tmpStr,2,12)))*60)+(integer(mid(l_tmpStr,2,15))))+(((date(mid(l_tmpStr,10,1)))-693975)*1440))*60)+(integer(mid(l_tmpStr,2,18)))) to l_tmpNum\r
+ set array_value of (Win32API_sort(current_object)) item l_i to l_tmpNum\r
+ set array_value of (Win32API_sort6(current_object)) item l_i to l_tmpNum\r
+ end\r
+ loop\r
+\r
+ send sort_items to Win32API_sort ascending\r
+\r
+ for l_i from 0 to argv2\r
+ get string_value of (Win32API_sort(current_object)) item l_i to l_tmpStr\r
+ if ((trim(uppercase(l_tmpStr))) <> "NULL") begin\r
+ for l_j from 0 to argv2\r
+ if (argv = 1) get string_value of (Win32API_result1(current_object)) item l_j to l_tmpStr2\r
+ if (argv = 2) get string_value of (Win32API_result2(current_object)) item l_j to l_tmpStr2\r
+ if (argv > 2) get string_value of (Win32API_sort6(current_object)) item l_j to l_tmpStr2\r
+\r
+ if (((trim(l_tmpStr2)) <> "NULL") and ((trim(l_tmpStr2)) <> "")) begin\r
+ if ((trim(lowercase(l_tmpStr))) = (trim(lowercase(l_tmpStr2)))) begin\r
+ get string_value of (Win32API_result1(current_object)) item l_j to l_tmpStr\r
+ set array_value of (Win32API_sort1(current_object)) item l_i to l_tmpStr\r
+ get integer_value of (Win32API_result2(current_object)) item l_j to l_tmpInt\r
+ set array_value of (Win32API_sort2(current_object)) item l_i to l_tmpInt\r
+ get string_value of (Win32API_result3(current_object)) item l_j to l_tmpStr\r
+ set array_value of (Win32API_sort3(current_object)) item l_i to l_tmpStr\r
+ get string_value of (Win32API_result4(current_object)) item l_j to l_tmpStr\r
+ set array_value of (Win32API_sort4(current_object)) item l_i to l_tmpStr\r
+ get string_value of (Win32API_result5(current_object)) item l_j to l_tmpStr\r
+ set array_value of (Win32API_sort5(current_object)) item l_i to l_tmpStr\r
+\r
+ if (argv = 1) set array_value of (Win32API_result1(current_object)) item l_j to "NULL"\r
+ if (argv = 2) set array_value of (Win32API_result2(current_object)) item l_j to "NULL"\r
+ if (argv > 2) set array_value of (Win32API_sort6(current_object)) item l_j to "NULL"\r
+\r
+ move argv2 to l_j\r
+ end\r
+ end\r
+ loop\r
+ end\r
+ loop\r
+ for l_i from 0 to argv2\r
+ get string_value of (Win32API_sort1(current_object)) item l_i to l_tmpStr\r
+ set array_value of (Win32API_result1(current_object)) item l_i to l_tmpStr\r
+ get string_value of (Win32API_sort2(current_object)) item l_i to l_tmpInt\r
+ set array_value of (Win32API_result2(current_object)) item l_i to l_tmpInt\r
+ get string_value of (Win32API_sort3(current_object)) item l_i to l_tmpStr\r
+ set array_value of (Win32API_result3(current_object)) item l_i to l_tmpStr\r
+ get string_value of (Win32API_sort4(current_object)) item l_i to l_tmpStr\r
+ set array_value of (Win32API_result4(current_object)) item l_i to l_tmpStr\r
+ get string_value of (Win32API_sort5(current_object)) item l_i to l_tmpStr\r
+ set array_value of (Win32API_result5(current_object)) item l_i to l_tmpStr\r
+ loop\r
+\r
+ send delete_data to Win32API_sort\r
+ send delete_data to Win32API_sort1\r
+ send delete_data to Win32API_sort2\r
+ send delete_data to Win32API_sort3\r
+ send delete_data to Win32API_sort4\r
+ send delete_data to Win32API_sort5\r
+\r
+ sorted:\r
+ function_return doneSort\r
+end_function\r
+\r
+// This function allows basic file operations delete, move, copy, rename\r
+// Useful where DataFlex internal functionssuch as erasefile or copyfile are flakey.\r
+// \r
+// fileOpp(<operation type>,<source file>,<dest file>)\r
+// <operation name> can be any of "COPY", "DELETE", "MOVE" or "RENAME"\r
+//\r
+// Example usage:\r
+//\r
+// fileOpp("delete","C:\FileTo.delete","")\r
+// fileOpp("move","C:\Source.file","C:\Destination.file")\r
+//\r
+function fileopp global string argv string argv2 string argv3 returns integer\r
+ local string sFileOp\r
+ local pointer lpFileOp lpArgv2 lpArgv3\r
+ local integer l_iResult\r
+\r
+ move 0 to l_iResult\r
+ move (trim(uppercase(argv))) to argv\r
+ move (trim(argv2)) to argv2\r
+ move (trim(argv3)) to argv3\r
+\r
+ if (((argv = "COPY") or (argv = "PRINT") or (argv = "DELETE") or (argv = "MOVE") or (argv = "RENAME")) and (argv2 <> "")) begin\r
+ zerotype _SHFILEOPSTRUCT to sFileOp\r
+ getaddress of sFileOp to lpFileOp\r
+\r
+ case begin\r
+ case (argv = "COPY") put FO_COPY to sFileOp at SHFILEOPSTRUCT.wFunc\r
+ case break\r
+ case (argv = "PRINT") put FO_COPY to sFileOp at SHFILEOPSTRUCT.wFunc\r
+ case break\r
+ case (argv = "DELETE") put FO_DELETE to sFileOp at SHFILEOPSTRUCT.wFunc\r
+ case break\r
+ case (argv = "MOVE") put FO_MOVE to sFileOp at SHFILEOPSTRUCT.wFunc\r
+ case break\r
+ case (argv = "RENAME") put FO_RENAME to sFileOp at SHFILEOPSTRUCT.wFunc\r
+ case break\r
+ case end\r
+\r
+ move (argv2+character(0)+character(0)) to argv2\r
+ move (argv3+character(0)+character(0)) to argv3\r
+ getAddress of argv2 to lpArgv2\r
+ put lpArgv2 to sFileOp at SHFILEOPSTRUCT.pFrom\r
+ \r
+ if (argv <> "DELETE") begin\r
+ getAddress Of argv3 to lpArgv3\r
+ put lpArgv3 to sFileOp at SHFILEOPSTRUCT.pTo\r
+ end \r
+\r
+ case begin\r
+ case (argv = "PRINT") put (FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT+FOF_NOERRORUI+FOF_NOCOPYSECURITYATTRIBS) to sFileOp at SHFILEOPSTRUCT.fFlags\r
+ case break\r
+ case else put (FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT+FOF_NOERRORUI) to sFileOp at SHFILEOPSTRUCT.fFlags\r
+ case break\r
+ case end\r
+ \r
+ // put ? to sFileOp at SHFILEOPSTRUCT.hWnd\r
+ // put ? to sFileOp at SHFILEOPSTRUCT.fAnyOperationsAborted\r
+ // put ? to sFileOp at SHFILEOPSTRUCT.hNameMappings\r
+ // put ? to sFileOp at SHFILEOPSTRUCT.lpszProgressTitle\r
+\r
+ move (SHFileOperation(lpFileOp)) to l_iResult\r
+ end\r
+\r
+ function_return l_iResult\r
+end_function\r
+\r
+// Get temp dir on local machine from windows registry\r
+function get_local_temp global integer argv returns string\r
+ local string lpBuffer\r
+ local integer l_01iResult\r
+ local pointer tmpPtr\r
+ \r
+ move (pad(lpBuffer,255)) to lpBuffer // this is a hack to allocate a specific size to a local string\r
+ getaddress of lpBuffer to tmpPtr\r
+ move (GetTempPath(255,tmpPtr)) to l_01iResult\r
+\r
+ function_return lpbuffer\r
+end_function\r
+\r
+// Get system dir on local machine from windows registry\r
+function get_local_system global integer argv returns string\r
+ local string sBuffer\r
+ local pointer lpBuffer l_iResult uSize\r
+\r
+ move 255 to uSize\r
+ move (repeat(character(0),(uSize+1))) to sBuffer \r
+ getAddress of sBuffer to lpBuffer\r
+ move (GetSystemDirectory(lpBuffer,uSize)) to l_iResult \r
+ \r
+ function_return (left(sBuffer,l_iResult))\r
+end_function\r
+\r
+// Function to open close cd tray dll - 0 to open 1 to close\r
+function cd_tray global integer argv returns integer\r
+ local integer l_iResult\r
+ local string l_sReturn l_sCmd \r
+ local pointer l_pCmd l_pReturn\r
+ \r
+ zerostring 127 to l_sCmd \r
+ getaddress of l_sCmd to l_pCmd\r
+ getaddress of l_sReturn to l_pReturn\r
+\r
+ if (argv = 0) move "set CDAudio door open" to l_sCmd\r
+ if (argv = 1) move "set CDAudio door closed" to l_sCmd\r
+ move (mciSendString(l_pCmd,l_pReturn,127,0)) to l_iResult\r
+ \r
+ function_return l_sReturn\r
+end_function\r
+\r
+// This function will force dataflex to exit with the error code in iReturnCode\r
+function exit_process global integer iReturnCode returns integer\r
+ local integer iVoid\r
+ \r
+ move (ExitProcessEx(iReturnCode)) To iVoid\r
+ \r
+ function_return iVoid\r
+end_function\r
+\r
+// Grab the process ID of dfruncon\r
+function get_process_id global integer argv returns integer\r
+ local integer iRVal\r
+ \r
+ move (GetPID()) TO iRVal\r
+ \r
+ function_return (Low(iRVal))\r
+end_function\r
+\r
+// Grab the computername\r
+function get_computer global integer argv returns string\r
+ local string strName lsSize\r
+ local pointer lpNameAddr lpSize\r
+ local integer l_01iResult\r
+\r
+ move (repeat(character(0),255)) to strName\r
+ getAddress of strName to lpNameAddr\r
+ move (repeat(character(0),_SIZEGETCOMPUTERNAME_SIZE)) to lsSize\r
+ put 16 to lsSize at SIZEGETCOMPUTERNAME.dwSize\r
+ getAddress of lsSize to lpSize\r
+ move (GetComputername(lpNameAddr, lpSize )) to l_01iResult\r
+ \r
+ if (l_01iResult) function_return (cstring(strName)) // return with terminating null char removed\r
+ else function_return "Unknown"\r
+end_function\r
+ \r
+// Grab the windows username\r
+function get_user_name global integer argv returns string\r
+ local string strName\r
+ local pointer lpNameAddr\r
+ local integer l_01iResult\r
+\r
+ move (repeat(character(0),255)) to strName\r
+ getAddress of strName to lpNameAddr\r
+ move (WNetGetUser(0, lpNameAddr, DWORDtoBytes(255))) to l_01iResult\r
+ if (l_01iResult = 0) function_return (uppercase(cstring(strName))) // return with terminating null char removed\r
+ else function_return "Unknown"\r
+end_function\r
+\r
+// Use a standard windows folder browser, takes the title of the browser, returns the file path\r
+function folder_browse global string argv returns String\r
+ local string sFolder sBrowseInfo sTitle\r
+ local pointer lpItemIdList lpsFolder lpsBrowseInfo lpsTitle\r
+ integer iFolderSelected l_iRetval\r
+\r
+ zeroType _BROWSEINFO to sBrowseInfo\r
+\r
+ if (argv<>"") begin\r
+ move argv to sTitle\r
+ getAddress of sTitle to lpsTitle\r
+ put lpsTitle to sBrowseInfo at BROWSEINFO.lpszTitle\r
+ end\r
+\r
+ put BIF_RETURNONLYFSDIRS+BIF_EDITBOX+BIF_BROWSEINCLUDEFILES to sBrowseInfo At BROWSEINFO.ulFlags\r
+ // put (window_handle(focus(desktop))) to sBrowseInfo At BROWSEINFO.hWndOwner ??\r
+ move (repeat(character(0),260)) to sFolder // set the size of sFolder to 128 by nulling in 8 chars\r
+ \r
+ getAddress Of sBrowseInfo to lpsBrowseInfo\r
+ getAddress Of sFolder to lpsFolder\r
+\r
+ move (SHBrowseForFolder(lpsBrowseInfo)) to lpItemIdList // select folder\r
+ move (SHGetPathFromIDList(lpItemIdList, lpsFolder)) to iFolderSelected // get folder name\r
+ move (CoTaskMemFree(lpItemIdList)) to l_iRetval // release memory used by ItemIdList\r
+\r
+ if (iFolderSelected = 0) move "" to sFolder\r
+ \r
+ function_return (cString(sFolder)) // return with terminating null char removed\r
+end_function\r
+\r
+// Function to convert a long filename into a windows short filename\r
+function get_short_path global string argv returns string\r
+ local string sShortPath sLongPath\r
+ local pointer lpszShortPath lpszLongPath\r
+ local integer cchBuffer l_iResult\r
+ \r
+ move (trim(argv)) to sLongPath\r
+ move 255 to cchBuffer\r
+ move (repeat(character(0),(cchBuffer+1))) to sShortPath\r
+ getaddress of sLongPath to lpszLongPath\r
+ getaddress of sShortPath to lpszShortPath\r
+ move (GetShortPathName(lpszLongPath,lpszShortPath,cchBuffer)) to l_iResult\r
+ \r
+ function_return (left(sShortPath,l_iResult))\r
+end_function\r
+\r
+// Set of function to disable close widgets of shell\r
+function disable_close global integer argv returns integer\r
+ local number Ret\r
+ local handle hWnd hMenu\r
+\r
+ if (g_sConsoleTitleIsSet <> "DataFlex") begin\r
+ // change the window title so we can find the window\r
+ move (SetConsoleTitle("DataFlex")) to strmark \r
+ move "DataFlex" to g_sConsoleTitleIsSet\r
+ // Give SetConsoleTitle a chance to take effect\r
+ sleep 1\r
+ end\r
+ \r
+ // find the window\r
+ move (FindWindow(0, "DataFlex")) to hWnd\r
+ // grab the menu\r
+ move (GetSystemMenu(hWnd, 0)) to hMenu\r
+ // disable the X\r
+ if (argv = 0) move (EnableMenuItem(hMenu, SC_CLOSE, (MF_BYCOMMAND ior MF_GRAYED))) to ret\r
+ // enable the X \r
+ if (argv = 1) move (EnableMenuItem(hMenu, SC_CLOSE, (MF_BYCOMMAND ior MF_ENABLED))) to ret\r
+ \r
+ function_return 0\r
+end_function\r
+\r
+// This function will run any external application directly from dataflex\r
+// argv = application to run (command name/path) argv2 = any parameters to pass to the program argv3 = directory to run from\r
+function shell_exec global string argv string argv2 string argv3 returns integer\r
+ local handle windowHandle\r
+ local pointer lpOperation lpFile lpParameters lpDirectory\r
+ local integer nShowCmd l_iResult\r
+ local string sOperation sFile sParameters sDirectory\r
+\r
+ if ((trim(argv)) <> "") begin\r
+ move 0 to windowHandle\r
+ move "open" to sOperation\r
+ move argv to sFile\r
+ if ((trim(argv2)) <> "") move argv2 to sParameters\r
+ else move "" to sParameters \r
+ if ((trim(argv3)) <> "") move argv3 to sDirectory\r
+ else move "" to sDirectory\r
+ move "" to sDirectory\r
+\r
+ getAddress of sOperation to lpOperation\r
+ getAddress of sFile to lpFile\r
+ getAddress of sParameters to lpParameters\r
+ getAddress of sDirectory to lpDirectory\r
+\r
+ move (ShellExecute(windowHandle,lpOperation,lpFile,lpParameters,lpDirectory,SW_SHOWMAXIMIZED)) to l_iResult\r
+ end\r
+end_function\r
+\r
+// This function will run the console application stated in argv1\r
+// argv2 = set to 1 to run the process in a new window\r
+// argv3 = set to 1 to leave the new process running and continue without killing it\r
+// argv4 = The time to live before killing the process - set to zero to wait until finished\r
+// Note - Setting argv3 to 1 will result in build up of open handles for finished processes \r
+// if term_proc is not used to terminate the process.\r
+// It is possible to have multiple processes running in one window by\r
+// setting argv2 = 0 and argv3 = 1, but handling how they behave on the screen \r
+// requires some careful fiddling.\r
+function create_proc global string argv integer argv2 integer argv3 integer argv4 returns string\r
+ local pointer lpProcessInformation lpStartupInformation\r
+ local integer l_iResult\r
+ local pointer lpApplicationName lpCommandLine lpProcessAttributes lpThreadAttributes lpEnvironment lpCurrentDirectory\r
+ local integer bInheritHandles iProcessAttributes iThreadAttributes iEnvironment \r
+ local dword dwCreationFlags dwMilliseconds\r
+ local string sProcessInformation sStartupInformation sApplicationName sCommandLine sCurrentDirectory l_sExit l_sTmp\r
+ local handle hProcess hThread\r
+ \r
+ zeroType _PROCESS_INFORMATION to sProcessInformation\r
+ zeroType _STARTUPINFO to sStartupInformation\r
+\r
+ move STRINGNULL to l_sExit\r
+ move STRINGNULL to sApplicationName\r
+ move argv to sCommandLine\r
+ move HEXNULL to iProcessAttributes\r
+ move HEXNULL to iThreadAttributes\r
+ move HEXTRUE to bInheritHandles\r
+ move HEXNULL to iEnvironment\r
+ move STRINGNULL to sCurrentDirectory\r
+ if (argv2 = 0) move NORMAL_PRIORITY_CLASS to dwCreationFlags\r
+ if (argv2 = 1) move (CREATE_NEW_CONSOLE+NORMAL_PRIORITY_CLASS) to dwCreationFlags\r
+ \r
+ getaddress of sApplicationName to lpApplicationName\r
+ getaddress of sCommandLine to lpCommandLine\r
+ getaddress of iProcessAttributes to lpProcessAttributes\r
+ getaddress of iThreadAttributes to lpThreadAttributes\r
+ getaddress of iEnvironment to lpEnvironment\r
+ getaddress of sCurrentDirectory to lpCurrentDirectory\r
+ getaddress of sProcessInformation to lpProcessInformation\r
+ getaddress of sStartupInformation to lpStartupInformation\r
+ \r
+ put (length(sStartupInformation)) to sStartupInformation at STARTUPINFO.cb\r
+ \r
+ move (CreateProcess(lpApplicationName,lpCommandLine,lpProcessAttributes,lpThreadAttributes,dwCreationFlags,dwCreationFlags,lpEnvironment,lpCurrentDirectory,lpStartupInformation,lpProcessInformation)) to l_iResult\r
+ \r
+ getbuff from sProcessInformation at PROCESS_INFORMATION.hProcess to hProcess\r
+ getbuff from sProcessInformation at PROCESS_INFORMATION.hThread to hThread\r
+\r
+ if (argv3 <> 1) begin\r
+ if (argv4 = 0) move INFINITE to dwMilliseconds\r
+ if (argv4 <> 0) move argv4 to dwMilliseconds\r
+ move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult\r
+ move (TerminateProcess(hProcess,HEXNULL)) to l_iResult\r
+ move (CloseHandle(hThread)) to l_iResult\r
+ move (CloseHandle(hProcess)) to l_iResult\r
+ end\r
+ if (argv3 = 1) begin \r
+ move hProcess to l_sExit\r
+ append l_sExit "|" hThread\r
+ end\r
+ \r
+ function_return l_sExit\r
+end_function\r
+\r
+// This will terminate a process started in create_proc with argv3 set to 1\r
+// move the string returned by create_proc to argv\r
+// set argv2 to 0 if you want to wait for the process to finish before terminating\r
+// set argv2 to 1 if you want to terminate the process without waiting for it to finish\r
+function term_proc global string argv integer argv2 returns integer\r
+ local integer l_iSuccess\r
+ local integer dwMilliseconds l_iResult\r
+ local handle hProcess hThread\r
+ \r
+ move 0 to l_iSuccess\r
+ move (trim(argv)) to argv\r
+ if ((argv contains "|") and ((length(argv)) >= 3)) begin \r
+ move (left(argv,(pos("|",argv)-1))) to hProcess\r
+ move (mid(argv,(length(argv)-pos("|",argv)),(pos("|",argv)+1))) to hThread\r
+ move INFINITE to dwMilliseconds\r
+ if (argv2 = 0) move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult\r
+ move (TerminateProcess(hProcess,HEXNULL)) to l_iResult\r
+ move (CloseHandle(hThread)) to l_iResult\r
+ move (CloseHandle(hProcess)) to l_iResult\r
+ end\r
+ \r
+ function_return l_iSuccess\r
+end_function\r
+\r
+// Check if a file is locked by a windows process\r
+// Returns 1 if the file is locked.\r
+function is_locked global string argv returns integer\r
+ local integer l_iResult l_iDllErr l_iThrow\r
+ local handle l_hFile \r
+ move 0 to l_iResult\r
+ move -1 to l_hFile\r
+ move (trim(argv)) to argv \r
+ if (argv <> "") begin\r
+ move (lOpen(argv,(OF_READ+OF_SHARE_EXCLUSIVE))) to l_hFile\r
+ move (GetLastError()) to l_iDllErr\r
+ if ((l_hFile = -1) and (l_iDllErr = 32)) move 1 to l_iResult\r
+ if (l_hFile <> -1) begin\r
+ move (lClose(l_hFile)) to l_iThrow\r
+ end\r
+ end\r
+ function_return l_iResult\r
+end_function\r
+\r
+// Check if a file exists. Returns 1 if the file exists.\r
+function does_exist global string argv returns integer\r
+ local integer l_iResult l_iDllErr l_iThrow\r
+ local handle l_hFile \r
+ move 0 to l_iResult\r
+ move -1 to l_hFile\r
+ move (trim(argv)) to argv \r
+ if (argv <> "") begin\r
+ move 1 to l_iResult\r
+ move (lOpen(argv,(OF_READ+OF_SHARE_DENY_NONE))) to l_hFile\r
+ move (GetLastError()) to l_iDllErr\r
+ if ((l_hFile = -1) and (l_iDllErr = 2)) move 0 to l_iResult\r
+ if (l_hFile <> -1) begin\r
+ move (lClose(l_hFile)) to l_iThrow\r
+ end\r
+ end\r
+ function_return l_iResult\r
+end_function\r
+\r
+// Read a text file line by line into the buffer array "Win32API_buffer"\r
+// Returns an integer i-1 where i is the count of array elements/lines.\r
+//\r
+// Ref: http:// msdn2.microsoft.com/en-us/library/aa365467.aspx\r
+function buffer_text_file global string argv string argv2 returns integer\r
+ local string l_sBuf l_sBufL l_structBytesRead l_sLine // String l_structBytesRead used with struct to overcome problem of df not being able to getaddress of integers\r
+ local handle l_hFileHandle l_hFile\r
+ local pointer l_pFileName l_pBuf l_pBytesRead\r
+ local integer l_iFileSize l_iThrow l_iBytesRead l_iBytesToRead l_i l_iDllErr l_iLines\r
+ \r
+ send delete_data to Win32API_buffer\r
+ move -1 to l_iLines\r
+ \r
+ move (trim(argv)) to argv\r
+ move (trim(argv2)) to argv2\r
+ move -1 to l_hFileHandle\r
+ move 0 to l_iBytesRead\r
+ move 1 to l_iBytesToRead\r
+ move "" to l_sLine\r
+ \r
+ if (argv <> "") begin\r
+ getaddress of argv to l_pFileName\r
+ move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile\r
+ move (GetFileSize(l_hFile,0)) to l_iFileSize\r
+ for l_i from 1 to l_iFileSize\r
+ // move (SetFilePointer(l_hFile,l_i,0,FILE_CURRENT)) to l_iThrow\r
+ zerostring 1 to l_sBuf\r
+ getaddress of l_sBuf to l_pBuf\r
+ zerotype _STRUCTBYTESREAD to l_structBytesRead\r
+ getaddress of l_structBytesRead to l_pBytesRead\r
+ move (ReadFile(l_hFile,l_pBuf,l_iBytesToRead,l_pBytesRead,HexNull)) to l_iThrow\r
+ getbuff from l_structBytesRead at STRUCTBYTESREAD.integer0 to l_iBytesRead\r
+ if ((ascii(l_sBuf) = 10) or (ascii(l_sBuf) = 13) or ((argv2 <> "") and (argv2 = l_sBuf))) begin\r
+ if (ascii(l_sBufL) <> 13) begin\r
+ increment l_iLines\r
+ set array_value of (Win32API_buffer(current_object)) item l_iLines to l_sLine\r
+ move "" to l_sLine\r
+ end\r
+ \r
+ end\r
+ if ((ascii(l_sBuf) <> 10) and (ascii(l_sBuf) <> 13) and ((argv2 = "") or (argv2 <> l_sBuf))) append l_sLine l_sBuf\r
+ move l_sBuf to l_sBufL\r
+ end \r
+ move (CloseHandle(l_hFile)) to l_iThrow\r
+ end\r
+ function_return l_iLines\r
+end_function\r
+\r
+// Return file size in bytes from win32\r
+function file_size_bytes global string argv returns integer\r
+ local integer l_iFileSize l_iThrow\r
+ local pointer l_pFileName\r
+ local handle l_hFile\r
+ \r
+ move -1 to l_iFileSize\r
+ \r
+ if (argv <> "") begin\r
+ getaddress of argv to l_pFileName\r
+ move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile\r
+ move (GetFileSize(l_hFile,0)) to l_iFileSize\r
+ move (CloseHandle(l_hFile)) to l_iThrow\r
+ end\r
+ \r
+ function_return l_iFileSize\r
+end_function\r
+\r
+// Attempt to convert a string from unicode to ASCII/cp850 via WideCharToMultiByte\r
+// http:// msdn2.microsoft.com/en-us/library/ms776420.aspx\r
+function to_ascii global string argv returns string\r
+ local string l_sAscii l_sUnicode\r
+ local pointer l_pAscii l_pUnicode\r
+ local integer l_iCharsNeeded l_iThrow\r
+ move (trim(argv)) to l_sUnicode\r
+ \r
+ if (l_sUnicode <> "") begin\r
+ zerostring 100 to l_sAscii\r
+ getAddress of l_sAscii to l_pAscii\r
+ getAddress of l_sUnicode to l_pUnicode\r
+ \r
+ // set the length of cchWideChar to -1 and function assumes null termination and calculates lenght itsself\r
+ move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,0,0,0,0)) to l_iCharsNeeded \r
+ move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,l_pAscii,l_iCharsNeeded,0,0)) to l_iThrow\r
+ end\r
+ function_return l_sAscii\r
+end_function\r
+\r
+// Attempt to convert a string from ASCII to unicode via MultiByteToWideChar\r
+function to_unicode global string argv returns string\r
+ local string l_sAscii l_sUnicode\r
+ local pointer l_pAscii l_pUnicode\r
+ local integer l_iCharsNeeded l_iThrow\r
+ move (trim(argv)) to l_sAscii\r
+ \r
+ if (l_sAscii <> "") begin\r
+ zerostring 100 to l_sUnicode\r
+ getAddress of l_sUnicode to l_pUnicode\r
+ getAddress of l_sAscii to l_pAscii\r
+ \r
+ // set the length of cchWideChar to -1 and function assumes null termination and calculates lenght itsself\r
+ move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,0,0,0,0)) to l_iCharsNeeded \r
+ move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow\r
+ end\r
+ function_return l_sUnicode \r
+end_function\r
+\r
+// Attempt to convert a string from ascii to UTF8 via WideCharToMultiByte\r
+function to_utf8 global string argv returns string\r
+ local string l_sUTF8 l_sUnicode\r
+ local pointer l_pUTF8 l_pUnicode\r
+ local integer l_iCharsNeeded l_iThrow\r
+ move (trim(argv)) to l_sUnicode\r
+ \r
+ if (l_sUnicode <> "") begin\r
+ zerostring 100 to l_sUTF8\r
+ getAddress of l_sUTF8 to l_pUTF8\r
+ getAddress of l_sUnicode to l_pUnicode\r
+ \r
+ // set the length of cchWideChar to -1 and function assumes null termination and calculates lenght itsself\r
+ move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,0,0,0,0)) to l_iCharsNeeded \r
+ move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow\r
+ end\r
+ \r
+ function_return l_sUTF8\r
+end_function\r
+\r
+// Get running processes on the system\r
+// http:// msdn2.microsoft.com/en-us/library/ms682629.aspx\r
+// in progress - currently churns out list of process id's to screen\r
+function get_procs global integer argv returns integer\r
+ local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules\r
+ local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid\r
+ local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules\r
+ local handle l_hProcess\r
+ \r
+ move (1024*10) to l_iBytes \r
+ zerostring l_iBytes to l_sProcesses\r
+ move 0 to l_iBytesBack\r
+ \r
+ getAddress of l_sProcesses to l_pProcesses \r
+ zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
+ getaddress of l_sStructBytesBack to l_pBytesBack\r
+ \r
+ move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow\r
+\r
+ getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack\r
+ \r
+ if (mod(l_iBytesBack,4) = 0) begin\r
+ for l_i from 1 to (l_iBytesBack/4)\r
+ move (left(l_sProcesses,4)) to l_sBuf\r
+ move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses\r
+ getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid \r
+ move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess\r
+ \r
+ move 1024 to l_iBytes2\r
+ zerostring l_iBytes2 to l_sModules\r
+ getAddress of l_sModules to l_pModules\r
+ zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
+ getaddress of l_sStructBytesBack to l_pBytesBack2\r
+ \r
+ move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow\r
+ getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2\r
+ \r
+ // Err here \r
+ showln l_i " PROC=" l_iPid " BYTES=" l_iBytesBack2 " H=" l_hProcess " LERR=" (GetLastError())\r
+ \r
+ // showln l_iBytesBack2 " " l_hProcess\r
+ if (mod(l_iBytesBack2,4) = 0) begin\r
+ for l_j from 1 to (l_iBytesBack2/4)\r
+ move (left(l_sModules,4)) to l_sBuf\r
+ move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules\r
+ getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid\r
+\r
+ loop\r
+ end\r
+ move (CloseHandle(l_hProcess)) to l_iThrow\r
+ \r
+ loop\r
+ end\r
+ \r
+ showln l_iThrow\r
+ showln "BYTES " l_iBytesBack\r
+ \r
+ function_return 0\r
+end_function\r
+\r
+// Returns the current system time via the GetSystemTime call\r
+// Takes an integer value; \r
+// 1 - displays individual segments comma separated\r
+// 0 - displays a formatted date time\r
+function time_data global integer argv returns string\r
+ local string sTimeData sResult sFormattedTime sFormattedDate\r
+ local pointer pTimeData pFormattedTime pFormattedDate\r
+ local integer iThrow iYear iMonth iDayOfWeek iDay iHour iMinute iSecond iMilliSeconds iLenCcTime iLenCcDate iDataLength\r
+ \r
+ zeroType _SYSTEMTIME to sTimeData\r
+ getAddress of sTimeData to pTimeData\r
+ move (GetSystemTime(pTimeData)) to iThrow\r
+ \r
+ // just return the structure comma separated\r
+ if (argv = 1) begin\r
+ getBuff from sTimeData at SYSTEMTIME.wYear to iYear\r
+ getBuff from sTimeData at SYSTEMTIME.wMonth to iMonth\r
+ getBuff from sTimeData at SYSTEMTIME.wDayOfWeek to iDayOfWeek\r
+ getBuff from sTimeData at SYSTEMTIME.wDay to iDay\r
+ getBuff from sTimeData at SYSTEMTIME.wHour to iHour\r
+ getBuff from sTimeData at SYSTEMTIME.wMinute to iMinute\r
+ getBuff from sTimeData at SYSTEMTIME.wSecond to iSecond\r
+ getBuff from sTimeData at SYSTEMTIME.wMilliSeconds to iMilliSeconds\r
+ \r
+ move "" to sResult\r
+ append sResult iYear "," iMonth "," iDay "," iHour "," iMinute "," iSecond "," iMilliSeconds\r
+ end \r
+ // give formatted date_time\r
+ if (argv = 0) begin \r
+ zerostring 255 to sFormattedTime\r
+ getaddress of sFormattedTime to pFormattedTime\r
+ move (length(sFormattedTime)) to iLenCcTime\r
+ \r
+ move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedTime, iLenCcTime)) to iDataLength\r
+\r
+ zerostring 255 To sFormattedDate\r
+ getaddress of sFormattedDate To pFormattedDate\r
+ move (length(sFormattedDate)) to iLenCcDate\r
+ \r
+ move (GetDateFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedDate, iLenCcDate)) to iDataLength\r
+ move (cstring(sFormattedDate)) to sResult\r
+ append sResult " " (cstring(sFormattedTime)) // terminating null char removed \r
+ end\r
+ function_return sResult\r
+end_function\r
+\r
+// Insert zeros into the correct places to make a field x wide (similar to zeropad)\r
+function fill_0 global integer iValue integer iSize returns string\r
+ local string sReturn\r
+\r
+ move iValue to sReturn\r
+ while (length(sReturn) < iSize)\r
+ insert '0' in sReturn at 1\r
+ end\r
+\r
+ function_return sReturn\r
+end_function\r
+\r
+// Checks the runtime date format and if it's not adding on the epoch add it\r
+function check_date_error global string sDate returns date\r
+ local integer iDate iY1k\r
+ local Date dDate\r
+\r
+ move sDate to iDate\r
+ move 693975 to iY1k\r
+\r
+ if (iDate < iY1k) Calc (iDate + iY1k) to iDate\r
+ move iDate to dDate\r
+\r
+ function_return dDate\r
+end_function\r
+\r
+// Get the mod time of a file\r
+// This is the core of the replacement / leap year fix of GET_FILE_MOD_TIME\r
+// Usage:\r
+// get_time(<file>, <mode>)\r
+// 1 = created time\r
+// 2 = accessed time\r
+// 3 = modified time\r
+// \r
+function get_time global string sFileName integer iMode returns string\r
+ local string sCreated sLastAccess sLastChanged sSystemTime sLocalTime sDate sTime sDateSep\r
+ Local pointer pCreated pLastAccess pLastChanged pSystemTime pLocalTime pFileName\r
+ Local handle hCheckFile\r
+ Local integer iResult iVal iDateSep iDateFormat iDate4State\r
+\r
+ move "" to sTime\r
+ move "" to sDate\r
+ \r
+ getaddress of sFileName to pFileName\r
+ move (CreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING , 0, 0)) to hCheckFile\r
+ \r
+ if (hCheckFile <> INVALID_HANDLE_VALUE) begin\r
+ zerotype _FILETIME to sCreated\r
+ zerotype _FILETIME to sLastAccess\r
+ zerotype _FILETIME to sLastChanged\r
+ zerotype _FILETIME to sLocalTime\r
+ getAddress of sCreated to pCreated\r
+ getAddress of sLastAccess to pLastAccess\r
+ getAddress of sLastChanged to pLastChanged\r
+ getAddress of sLocalTime to pLocalTime\r
+\r
+ move (GetFileTime (hCheckFile, pCreated, pLastAccess, pLastChanged)) to iResult \r
+ \r
+ if (iResult) begin\r
+ if (iMode = 1) move (FileTimeToLocalFileTime(pCreated,pLocalTime)) to iResult\r
+ else if (iMode = 2) move (FileTimeToLocalFileTime(pLastAccess, pLocalTime)) to iResult\r
+ else if (iMode = 3) move (FileTimeToLocalFileTime(pLastChanged, pLocalTime)) to iResult\r
+ \r
+ zerotype _SYSTEMTIME2 to sSystemTime\r
+ getAddress of sSystemTime to pSystemTime\r
+\r
+ move (FileTimeToSystemTime(pLocalTime, pSystemTime)) to iResult\r
+\r
+ get_attribute DF_DATE_SEPARATOR to iDateSep\r
+ move (character(iDateSep)) to sDateSep\r
+ get_attribute DF_DATE_FORMAT to iDateFormat\r
+\r
+ if (iDateFormat = DF_DATE_USA) begin\r
+ getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
+ append sDate (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
+ append sDate sDateSep (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
+ append sDate sDateSep (fill_0(iVal,4))\r
+ end\r
+ else if iDateFormat eq DF_DATE_EUROPEAN begin\r
+ getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
+ append sDate (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
+ append sDate sDateSep (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
+ append sDate sDateSep (fill_0(iVal,4))\r
+ end\r
+ else if iDateFormat eq DF_DATE_MILITARY begin\r
+ getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
+ append sDate (fill_0(iVal,4))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
+ append sDate sDateSep (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
+ append sDate sDateSep (fill_0(iVal,2))\r
+ end\r
+\r
+ getbuff from sSystemTime at SYSTEMTIME2.wHour to iVal\r
+ append sTime (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wMinute to iVal\r
+ append sTime ":" (fill_0(iVal,2))\r
+ getbuff from sSystemTime at SYSTEMTIME2.wSecond to iVal\r
+ append sTime ":" (fill_0(iVal,2))\r
+\r
+ append sDate sTime\r
+ end\r
+ move (CloseHandle (hCheckFile)) to iResult\r
+ end\r
+\r
+ function_return sDate\r
+end_function\r
+\r
+// Create a guid GUID (Microsoft)\r
+function create_guid global returns string \r
+ local integer l_iThrow\r
+ local pointer l_ptGUID l_ptGUIDString\r
+ local string l_stGUID l_stGUIDString l_sResult\r
+ \r
+ zerotype _GUID to l_stGUID\r
+ getaddress of l_stGUID to l_ptGUID\r
+\r
+ zerostring GUID_STRING_LENGTH to l_stGUIDString\r
+ getaddress of l_stGUIDString to l_ptGUIDString\r
+ \r
+ if (CoCreateGuid(l_ptGUID) = 0) begin\r
+ // If successfully created put it in a string\r
+ move (StringFromGUID2(l_ptGUID, l_ptGUIDString, GUID_STRING_LENGTH)) to l_iThrow\r
+ move (cstring(to_ascii(l_stGUIDString))) to l_sResult\r
+ end\r
+ \r
+ function_return l_sResult\r
+end_function\r
+\r
+// Get textual description of a win32 error returned by GetLastError()\r
+function get_last_error_detail global integer iError returns string\r
+ local integer l_iThrow\r
+ local string l_sBuf \r
+ local pointer l_pBuf\r
+ \r
+ zerostring 200 to l_sBuf\r
+ getaddress of l_sBuf to l_pBuf\r
+ \r
+ move (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, iError, LANG_NEUTRAL, l_pBuf, 200, 0)) to l_iThrow\r
+ \r
+ function_return (string(iError)+": "+l_sBuf)\r
+end_function\r
+\r
+// Get system disk info\r
+// argv1 = disk mount point i.e. c:\\r
+// argv2 = "" or "TOTAL", where TOTAL returns free and blank displays used.\r
+function disk_info global string argv string argv2 returns number\r
+ local string l_sSectorsPerCluster l_sBytesPerSector l_sNumberOfFreeClusters l_sTotalNumberOfClusters\r
+ local pointer l_pSectorsPerCluster l_pBytesPerSector l_pNumberOfFreeClusters l_pTotalNumberOfClusters\r
+ local number l_iSectorsPerCluster l_iBytesPerSector l_iNumberOfFreeClusters l_iTotalNumberOfClusters l_iSpace\r
+ \r
+ move 0 to l_iSpace\r
+\r
+ if (argv <> "") begin\r
+ zerotype _DISKDATA1 to l_sSectorsPerCluster\r
+ zerotype _DISKDATA2 to l_sBytesPerSector \r
+ zerotype _DISKDATA3 to l_sNumberOfFreeClusters \r
+ zerotype _DISKDATA4 to l_sTotalNumberOfClusters\r
+\r
+ getaddress of l_sSectorsPerCluster to l_pSectorsPerCluster\r
+ getaddress of l_sBytesPerSector to l_pBytesPerSector\r
+ getaddress of l_sNumberOfFreeClusters to l_pNumberOfFreeClusters\r
+ getaddress of l_sTotalNumberOfClusters to l_pTotalNumberOfClusters\r
+\r
+ showln (GetDiskFreeSpace(argv, l_pSectorsPerCluster, l_pBytesPerSector, l_pNumberOfFreeClusters, l_pTotalNumberOfClusters))\r
+\r
+ getbuff from l_sSectorsPerCluster at DISKDATA1.sectorsPerCluster to l_iSectorsPerCluster\r
+ getbuff from l_sBytesPerSector at DISKDATA2.bytesPerSector to l_iBytesPerSector\r
+ getbuff from l_sNumberOfFreeClusters at DISKDATA3.numberOfFreeClusters to l_iNumberOfFreeClusters\r
+ getbuff from l_sTotalNumberOfClusters at DISKDATA4.totalNumberOfClusters to l_iTotalNumberOfClusters\r
+\r
+ // showln l_iSectorsPerCluster\r
+ // showln l_iBytesPerSector \r
+ // showln l_iNumberOfFreeClusters\r
+ // showln l_iTotalNumberOfClusters\r
+ \r
+ if (argv2 = "TOTAL") calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iTotalNumberOfClusters) to l_iSpace\r
+ else calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iNumberOfFreeClusters) to l_iSpace\r
+ end\r
+ \r
+ function_return l_iSpace\r
+end_function\r
+\r
+// Get system memory usage\r
+function get_mem_usage global returns integer\r
+ local integer l_iThrow l_iPid l_iMem\r
+ local string l_sProcessMemoryCounters\r
+ local pointer l_lpProcessMemoryCounters\r
+ local handle l_hProcess\r
+\r
+ zeroType _PROCESS_MEMORY_COUNTERS to l_sProcessMemoryCounters\r
+ getaddress of l_sProcessMemoryCounters to l_lpProcessMemoryCounters\r
+\r
+ put (length(l_sProcessMemoryCounters)) to l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.cb\r
+\r
+ move (get_process_id(0)) to l_iPid\r
+ move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess\r
+\r
+ move (GetProcessMemoryInfo(l_hProcess, l_lpProcessMemoryCounters, length(l_sProcessMemoryCounters))) to l_iThrow\r
+ getbuff from l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.WorkingSetSize to l_iMem\r
+ \r
+ // showln l_hProcess " " l_iThrow\r
+ // showln (GetLastError())\r
+ // showln (get_last_error_detail(GetLastError()))\r
+\r
+ function_return l_iMem\r
+end_function\r
+\r
+// Uses Microsofts InternetCanonicalizeUrl functionality\r
+// http:// msdn.microsoft.com/en-us/library/windows/desktop/aa384342%28v=vs.85%29.aspx\r
+// https:// groups.google.com/forum/#!topic/microsoft.public.vb.winapi/0RY8jPsx_14\r
+function urldecode global string argv returns string\r
+ local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult\r
+ local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength \r
+ local integer l_iwBufferLength l_iResult l_iDllErr\r
+\r
+ move argv to l_szUrl\r
+ move argv to l_sResult\r
+ \r
+ if (length(l_szUrl) > 0) begin\r
+ zerostring ((length(l_szUrl))+1) to l_szBuffer\r
+ getaddress of l_szUrl to l_lpszUrl\r
+ getaddress of l_szBuffer to l_lpszBuffer\r
+ \r
+ zerotype _STRUCTBYTESREAD to l_szStructBytesRead\r
+ put ((length(l_szBuffer))*4) to l_szStructBytesRead at STRUCTBYTESREAD.integer0 // allow 4 bytes per char to generously allow for any length changes (should be 2)\r
+ getaddress of l_szStructBytesRead to l_lpdwBufferLength\r
+\r
+ move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_NO_ENCODE+ICU_DECODE)) to l_iResult\r
+\r
+ getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
+\r
+ if (l_iResult <> 1) begin\r
+ move (GetLastError()) to l_iDllErr\r
+ custom_error ERROR_CODE_URLDECODE$ ERROR_MSG_URLDECODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))\r
+ end\r
+ move (cstring(l_szBuffer)) to l_sResult \r
+ end \r
+ function_return l_sResult \r
+end_function\r
+\r
+// Uses Microsofts InternetCanonicalizeUrl functionality\r
+// Only encodes parts before ? and #\r
+function urlencode global string argv returns string\r
+ local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult\r
+ local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength \r
+ local integer l_iwBufferLength l_iResult l_iDllErr\r
+\r
+ move argv to l_szUrl\r
+ move argv to l_sResult\r
+ if (length(l_szUrl) > 0) begin\r
+ zerostring ((length(l_szUrl))+1) to l_szBuffer\r
+ getaddress of l_szUrl to l_lpszUrl\r
+ getaddress of l_szBuffer to l_lpszBuffer\r
+ \r
+ zerotype _STRUCTBYTESREAD to l_szStructBytesRead\r
+ put ((length(l_szBuffer))*4) to l_szStructBytesRead at STRUCTBYTESREAD.integer0 // allow 4 bytes per char to generously allow for any length changes (should be 2)\r
+ getaddress of l_szStructBytesRead to l_lpdwBufferLength\r
+\r
+ move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_BROWSER_MODE)) to l_iResult\r
+\r
+ getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
+\r
+ if (l_iResult <> 1) begin\r
+ move (GetLastError()) to l_iDllErr\r
+ custom_error ERROR_CODE_URLENCODE$ ERROR_MSG_URLENCODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))\r
+ end\r
+ move (cstring(l_szBuffer)) to l_sResult \r
+ end \r
+ function_return l_sResult \r
+end_function\r
+\r
+// Functions to pull windows os version string\r
+function get_os_version global returns string\r
+ local string l_sOsInfo l_sVersion l_sReturn\r
+ local pointer l_pOsInfo\r
+ local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform\r
+ \r
+ move "" to l_sVersion\r
+ \r
+ zerotype _OSVERSIONINFO to l_sOsInfo\r
+ put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize\r
+ getaddress of l_sOsInfo to l_pOsInfo\r
+ \r
+ move (GetVersionEx(l_pOsInfo)) to l_iResult\r
+ \r
+ if (l_iResult = 1) begin\r
+ getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor\r
+ getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor\r
+ getbuff from l_sOsInfo at OSVERSIONINFO.dwBuildNumber to l_iBuild\r
+ getbuff from l_sOsInfo at OSVERSIONINFO.dwPlatformId to l_iPlatform\r
+ // getbuff from l_sOsInfo at OSVERSIONINFO.szCSDVersion to l_sVersion !??\r
+ move (cstring(right(l_sOsInfo,128))) to l_sVersion\r
+ end\r
+ \r
+ move ("Windows Version: "+string(l_iMajor)+"."+string(l_iMinor)+" Build: "+string(l_iBuild)+" Platform: "+string(l_iPlatform)+" CSDVersion: "+l_sVersion) to l_sReturn\r
+ \r
+ function_return l_sReturn \r
+end_function\r
+\r
+// Functions to pull windows os version as a numeric value\r
+function get_os_version_numeric global returns number\r
+ local string l_sOsInfo l_sVersion\r
+ local pointer l_pOsInfo\r
+ local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform\r
+ \r
+ move "" to l_sVersion\r
+ \r
+ zerotype _OSVERSIONINFO to l_sOsInfo\r
+ put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize\r
+ getaddress of l_sOsInfo to l_pOsInfo\r
+ \r
+ move (GetVersionEx(l_pOsInfo)) to l_iResult\r
+ \r
+ if (l_iResult = 1) begin\r
+ getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor\r
+ getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor\r
+ end\r
+ \r
+ function_return (number(l_iMajor)+(number(l_iMinor)/10))\r
+end_function\r
+\r
+// Converts binary to hex or base64 strings and vice versa\r
+function binary_to_string_to_binary global string argv string argv2 string argv3 returns string\r
+ local string l_sData l_sDataDecoded l_sDataSizeDecoded l_sReturn\r
+ local pointer l_pData l_pDataDecoded l_pDataSizeDecoded\r
+ local integer l_iResult l_iDataSize l_iDataSizeDecoded l_iOffset\r
+ \r
+ move argv to l_sData\r
+ move (length(l_sData)) to l_iDataSize\r
+ getaddress of l_sData to l_pData\r
+ \r
+ zerostring ((length(l_sData)*4)+1) to l_sDataDecoded\r
+ getaddress of l_sDataDecoded to l_pDataDecoded\r
+ \r
+ zerotype _DW_TYPE to l_sDataSizeDecoded\r
+ put (length(l_sDataDecoded)) to l_sDataSizeDecoded at DW_TYPE.value\r
+ getaddress of l_sDataSizeDecoded to l_pDataSizeDecoded \r
+ \r
+ case begin\r
+ case (argv2 = "HEX") begin\r
+ if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult\r
+ if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult\r
+ end\r
+ case break\r
+ case (argv2 = "BASE64") begin\r
+ if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult\r
+ if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult\r
+ end\r
+ case break\r
+ case else custom_error ERROR_CODE_UNKNOWN_FORMAT$ ERROR_MSG_UNKNOWN_FORMAT argv2\r
+ case end\r
+\r
+ getbuff from l_sDataSizeDecoded at DW_TYPE.value to l_iDataSizeDecoded\r
+\r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: " (ternary(argv3 = 0, "CryptBinaryToString", "CryptStringToBinary")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ showln "DATA = " l_sDataDecoded\r
+ showln "SIZE = " l_iDataSizeDecoded\r
+ end\r
+ else begin\r
+ if (argv3 = 0) move (replaces(character(9),replaces(character(10),replaces(character(13),replaces(character(32),cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset)),""),""),""),"")) to l_sReturn \r
+ else move (cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset))) to l_sReturn\r
+ end\r
+ \r
+ function_return l_sReturn\r
+end_function\r
+\r
+// Convert binary data to hex or base64 \r
+function binary_to_string global string argv string argv2 returns string\r
+ function_return (binary_to_string_to_binary(argv, argv2, 0))\r
+end_function\r
+// Convert hex or base64 strings to binary data\r
+function string_to_binary global string argv string argv2 returns string\r
+ function_return (binary_to_string_to_binary(argv, argv2, 1))\r
+end_function\r
+\r
+// List out cryptographic providers on ms windows\r
+function ms_adv_listproviders global returns integer\r
+ local integer l_i l_iResult l_iType\r
+ local string l_sType l_sName l_sNameSize\r
+ local pointer l_pType l_pName l_pNameSize\r
+\r
+ move -1 to l_i\r
+ repeat\r
+ increment l_i\r
+ \r
+ zerotype _DW_TYPE to l_sType\r
+ getaddress of l_sType to l_pType\r
+ \r
+ zerostring 255 to l_sName\r
+ getaddress of l_sName to l_pName\r
+ \r
+ zerotype _DW_TYPE to l_sNameSize\r
+ put length(l_sName) to l_sNameSize at DW_TYPE.value\r
+ getaddress of l_sNameSize to l_pNameSize\r
+ \r
+ move (CryptEnumProviders(l_i, HEXNULL, 0, l_pType, l_pName, l_pNameSize)) to l_iResult\r
+\r
+ if ((l_iResult <> 1) and (GetLastError() <> 0) and (GetLastError() <> 259)) begin\r
+ showln "ERROR: " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ getbuff from l_sType at DW_TYPE.value to l_iType\r
+ \r
+ if (l_iResult = 1) showln l_i ") " l_iType " - '" (cstring(l_sName)) "'"\r
+ until (l_iResult <> 1)\r
+\r
+end_function\r
+\r
+//-------------------------------------------------------------------------\r
+// Classes\r
+//-------------------------------------------------------------------------\r
+\r
+// Object to provide basic implimentations of some popular hash algorithms and encryption\r
+// provided by the Microsoft Cryptographic Provider\r
+//\r
+// Send message methods:\r
+//\r
+// aquire_context - Create the context of the Microsoft CSP\r
+// release_context - Release the context of the Microsoft CSP\r
+// import_key <key> <ealg> - Incomplete/WIP\r
+// derive_key <psw> <halg> <ealg>- Derives an encryption key provider when supplied\r
+// with a password, a hash algorithm and the required \r
+// encryption.\r
+// modify_key_iv <iv> - Set the initilization vector of the key provider\r
+// modify_key_mode <mode> - Set the key provider mode E.g. CBC, ECB etc\r
+// destroy_key - Dispose of the current key provider\r
+//\r
+// Get methods:\r
+// hash_data <data> <halg> - Returns a hash of the passed data in the specified \r
+// algorithm\r
+// export_key - Returns the current encryption key\r
+// generate_random_key_iv - Generates and sets a random initilization vector \r
+// for the key provider\r
+// encrypt <data> - Encrypt data\r
+// decrypt <data> - Decrypt data\r
+//\r
+// Example usage:\r
+// \r
+// object test is an msAdvCrypt\r
+// end_object\r
+// string data buf\r
+// \r
+// // Generate a hash\r
+// send aquire_context to test\r
+// get hash_data of test "MYTEXT" "SHA1" to data\r
+// send release_context to test\r
+// showln "HASHED: " (binary_to_string(data,"HEX"))\r
+// \r
+// // Encrypt some data\r
+// send aquire_context to test\r
+// send derive_key to test "MYPASSWORD" "SHA256" "AES_256"\r
+// send modify_key_mode to test "CBC"\r
+// get generate_random_key_iv of test to buf\r
+// move buf to data\r
+// get encrypt of test "MYDATA" to buf\r
+// append data buf\r
+// send destroy_key to test\r
+// send release_context to test\r
+// showln "ENCRYPTED: " (binary_to_string(data,"HEX"))\r
+// \r
+// // Decrypt some data\r
+// send aquire_context to test\r
+// send derive_key to test "MYPASSWORD" "SHA256" "AES_256"\r
+// send modify_key_mode to test "CBC"\r
+// send modify_key_iv to test (mid(data,16,1))\r
+// get decrypt of test (mid(data,length(data)-16,17)) to data\r
+// send destroy_key to test\r
+// send release_context to test\r
+// showln "DECRYPTED: " data\r
+// \r
+class msAdvCrypt is an array\r
+ procedure construct_object string argc \r
+ forward send construct_object argc\r
+ \r
+ property handle c_hProv \r
+ property handle c_hHash \r
+ property handle c_hKey\r
+ property string c_sAlg\r
+ end_procedure\r
+\r
+ procedure aquire_context\r
+ local integer l_iResult\r
+ local handle l_hProv\r
+ local string l_shProv\r
+ local pointer l_phProv\r
+ \r
+ zerotype _DW_TYPE to l_shProv\r
+ getaddress of l_shProv to l_phProv\r
+ \r
+ if (get_os_version_numeric() < 5.2) begin\r
+ move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult\r
+ if (GetLastError() = -2146893802) begin\r
+ move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult\r
+ end\r
+ end\r
+ else begin\r
+ move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult\r
+ if (GetLastError() = -2146893802) begin\r
+ move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult\r
+ end\r
+ end\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptAcquireContext " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ else begin\r
+ getbuff from l_shProv at DW_TYPE.value to l_hProv\r
+ set c_hProv to l_hProv\r
+ end \r
+ end_procedure\r
+ \r
+ function make_hash string in_data string in_hashalgorithm returns string\r
+ local integer l_iResult l_iHashSize\r
+ local string l_shHash l_sHash l_sRawString l_sHashSize\r
+ local handle l_hProv l_hHash\r
+ local pointer l_phHash l_pHash l_pRawString l_pHashSize\r
+ \r
+ get c_hProv to l_hProv\r
+ \r
+ if (l_hProv = 0) begin\r
+ custom_error ERROR_CODE_NO_CONTEXT$ ERROR_MSG_NO_CONTEXT\r
+ end\r
+ else begin\r
+ move in_data to l_sRawString\r
+ getaddress of l_sRawString to l_pRawString\r
+ \r
+ zerotype _HCRYPTHASH to l_shHash\r
+ getaddress of l_shHash to l_phHash \r
+ \r
+ case begin\r
+ case (in_hashalgorithm = "MD5") begin\r
+ move (CryptCreateHash(l_hProv, CALG_MD5, 0, 0, l_phHash)) to l_iResult\r
+ zerostring (128/8) to l_sHash\r
+ end\r
+ case break \r
+ case ((in_hashalgorithm = "SHA1") or (in_HASHalgorithm = "SHA")) begin\r
+ move (CryptCreateHash(l_hProv, CALG_SHA1, 0, 0, l_phHash)) to l_iResult\r
+ zerostring (160/8) to l_sHash\r
+ end\r
+ case break\r
+ case (in_hashalgorithm = "SHA256") begin\r
+ move (CryptCreateHash(l_hProv, CALG_SHA_256, 0, 0, l_phHash)) to l_iResult\r
+ zerostring (256/8) to l_sHash \r
+ end\r
+ case break\r
+ case (in_hashalgorithm = "SHA384") begin\r
+ move (CryptCreateHash(l_hProv, CALG_SHA_384, 0, 0, l_phHash)) to l_iResult\r
+ zerostring (384/8) to l_sHash \r
+ end\r
+ case break\r
+ case (in_hashalgorithm = "SHA512") begin\r
+ move (CryptCreateHash(l_hProv, CALG_SHA_512, 0, 0, l_phHash)) to l_iResult\r
+ zerostring (512/8) to l_sHash \r
+ end\r
+ case break \r
+ case else begin\r
+ custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_hashalgorithm\r
+ end\r
+ case end \r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptCreateHash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ \r
+ getbuff from l_shHash at HCRYPTHASH.value to l_hHash\r
+ getaddress of l_sHash to l_pHash\r
+ \r
+ move (CryptHashData(l_hHash, l_pRawString, (length(l_sRawString)), 0)) to l_iResult\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: Crypthash_data " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ \r
+ zerotype _DW_TYPE to l_sHashSize\r
+ put (length(l_sHash)) to l_sHashSize at DW_TYPE.value\r
+ getaddress of l_sHashSize to l_pHashSize\r
+ \r
+ move (CryptGetHashParam(l_hHash, HP_HASHVAL, l_pHash, l_pHashSize, 0)) to l_iResult\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptGetHashParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end \r
+ \r
+ getbuff from l_sHashSize at DW_TYPE.value to l_iHashSize\r
+\r
+ if (l_iHashSize <> length(l_sHash)) begin\r
+ showln "WARNING: Binary data does not match expected hash size:"\r
+ showln "DATA = " l_sHash\r
+ showln "SIZE = " l_iHashSize " / " (length(l_sHash))\r
+ end \r
+ end\r
+ \r
+ set c_hHash to l_hHash \r
+ \r
+ function_return (mid(l_sHash,l_iHashSize,1))\r
+ end_function \r
+ \r
+ procedure destroy_hash\r
+ local integer l_iResult\r
+ local handle l_hHash\r
+ \r
+ get c_hHash to l_hHash\r
+\r
+ if (l_hHash <> 0) begin\r
+ move (CryptDestroyHash(l_hHash)) to l_iResult\r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: Cryptdestroy_hash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end \r
+ else set c_hHash to 0\r
+ end \r
+ end_procedure\r
+\r
+ function hash_data string in_data string in_hashalgorithm returns string\r
+ local integer l_iResult\r
+ local string l_sHash\r
+ \r
+ get make_hash in_data in_hashalgorithm to l_sHash\r
+ send destroy_hash\r
+ \r
+ function_return (cstring(l_sHash))\r
+ end_function \r
+ \r
+ //WIP\r
+ procedure import_key string in_key string in_algorithm\r
+ local integer l_iResult\r
+ local string l_sBlobHeader l_sPlainTextKeyBlob l_shKey\r
+ local handle l_hProv l_hKey\r
+ local pointer l_pPlainTextKeyBlob l_phKey\r
+ \r
+ get c_hProv to l_hProv \r
+ \r
+ zerotype _BLOBHEADER to l_sBlobHeader \r
+ put PLAINTEXTKEYBLOB to l_sBlobHeader at BLOBHEADER.bType\r
+ put 2 to l_sBlobHeader at BLOBHEADER.bVersion\r
+ put 0 to l_sBlobHeader at BLOBHEADER.Reserved\r
+ \r
+ case begin \r
+ case (in_algorithm = "DES") put CALG_DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "3DES") put CALG_3DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "3DES_112") put CALG_3DES_112 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "AES") put CALG_AES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "AES_128") put CALG_AES_128 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "AES_192") put CALG_AES_192 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "AES_256") put CALG_AES_256 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "RC2") put CALG_RC2 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
+ case break \r
+ case (in_algorithm = "RC4") put CALG_RC4 to l_sBlobHeader at BLOBHEADER.ALG_ID \r
+ case break \r
+ case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
+ case end\r
+ \r
+ zerotype _PLAINTEXTKEYBLOB to l_sPlainTextKeyBlob\r
+ put l_sBlobHeader to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.BLOBHEADER\r
+ put (length(in_key)) to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.dwKeySize\r
+ put_string in_key to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.rgbKeyData \r
+ \r
+ getaddress of l_sPlainTextKeyBlob to l_pPlainTextKeyBlob\r
+ \r
+ zerotype _HCRYPTKEY to l_shKey\r
+ getaddress of l_shKey to l_phKey\r
+ \r
+ move (CryptImportKey(l_hProv, l_pPlainTextKeyBlob, length(l_sPlainTextKeyBlob), 0, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptImportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ \r
+ getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
+ \r
+ end_procedure\r
+ \r
+ procedure derive_key string in_data string in_hashalgorithm string in_algorithm\r
+ local integer l_iResult\r
+ local handle l_hProv l_hHash l_hKey\r
+ local string l_sKey l_shKey\r
+ local pointer l_phKey\r
+ \r
+ get c_hProv to l_hProv \r
+ get make_hash in_data in_hashalgorithm to l_sKey \r
+ get c_hHash to l_hHash\r
+\r
+ if (l_hHash <> 0) begin\r
+ zerotype _HCRYPTKEY to l_shKey\r
+ getaddress of l_shKey to l_phKey\r
+\r
+ // The default cipher mode to be used depends on the underlying CSP and the algorithm that's being used, but it's generally CBC mode\r
+ case begin\r
+ case (in_algorithm = "DES") move (CryptDeriveKey(l_hProv, CALG_DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "3DES") move (CryptDeriveKey(l_hProv, CALG_3DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "3DES_112") move (CryptDeriveKey(l_hProv, CALG_3DES_112, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "AES") move (CryptDeriveKey(l_hProv, CALG_AES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "AES_128") move (CryptDeriveKey(l_hProv, CALG_AES_128, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "AES_192") move (CryptDeriveKey(l_hProv, CALG_AES_192, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "AES_256") move (CryptDeriveKey(l_hProv, CALG_AES_256, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "RC2") move (CryptDeriveKey(l_hProv, CALG_RC2, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case (in_algorithm = "RC4") move (CryptDeriveKey(l_hProv, CALG_RC4, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
+ case break \r
+ case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
+ case end\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptDeriveKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ else begin \r
+ getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
+ set c_sAlg to in_algorithm\r
+ end\r
+\r
+ set c_hKey to l_hKey\r
+ end\r
+ end_procedure\r
+ \r
+ procedure modify_key_iv string in_iv\r
+ local integer l_iResult l_iBlockSize\r
+ local handle l_hKey\r
+ local string l_sIV l_sAlg\r
+ local pointer l_pIV\r
+ \r
+ get c_hKey to l_hKey\r
+ get c_sAlg to l_sAlg\r
+ \r
+ // Set expected block size in bytes\r
+ case begin\r
+ case (l_sAlg contains "DES") calc (64/8) to l_iBlockSize\r
+ case break \r
+ case (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
+ case break \r
+ case (l_sAlg = "RC2") calc (64/8) to l_iBlockSize\r
+ case break \r
+ case else custom_error ERROR_CODE_INCOMPATIBLE_ALGORITHM$ ERROR_MSG_INCOMPATIBLE_ALGORITHM l_sAlg\r
+ case end\r
+ \r
+ if (length(in_iv) <> l_iBlockSize) custom_error ERROR_CODE_INVALID_BLOCKSIZE$ ERROR_MSG_INVALID_BLOCKSIZE (l_sAlg+"="+string(l_iBlockSize)+" NOT "+string(length(in_iv)))\r
+ \r
+ move in_iv to l_sIV\r
+ getaddress of l_sIV to l_pIV\r
+ \r
+ move (CryptSetKeyParam(l_hKey, KP_IV, l_pIV, 0)) to l_iResult\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end \r
+ \r
+ end_procedure\r
+ \r
+ function generate_random_key_iv returns string\r
+ local integer l_i l_iBlockSize\r
+ local string l_sIV l_sAlg \r
+ \r
+ get c_sAlg to l_sAlg\r
+ move "" to l_sIV\r
+ \r
+ if ((l_sAlg contains "DES") or (l_sAlg = "RC2")) calc (64/8) to l_iBlockSize\r
+ if (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
+ \r
+ for l_i from 1 to l_iBlockSize\r
+ append l_sIV (character(48+random(47)))\r
+ loop\r
+ \r
+ send modify_key_iv l_sIV\r
+ \r
+ function_return l_sIV\r
+ end_function\r
+ \r
+ procedure modify_key_mode string in_mode\r
+ local integer l_iResult\r
+ local handle l_hKey\r
+ local string l_sMode l_sbData\r
+ local pointer l_pbData\r
+ \r
+ get c_hKey to l_hKey\r
+\r
+ case begin\r
+ case (in_mode contains "CBC") move CRYPT_MODE_CBC to l_sMode\r
+ case break\r
+ case (in_mode contains "ECB") move CRYPT_MODE_ECB to l_sMode\r
+ case break\r
+ case (in_mode contains "OFB") move CRYPT_MODE_OFB to l_sMode\r
+ case break\r
+ case (in_mode contains "CFB") move CRYPT_MODE_CFB to l_sMode\r
+ case break\r
+ case (in_mode contains "CTS") move CRYPT_MODE_CTS to l_sMode\r
+ case break \r
+ case else custom_error ERROR_CODE_UNRECOGNISED_MODE$ ERROR_MSG_UNRECOGNISED_MODE l_sMode \r
+ case end\r
+ \r
+ zerotype _DW_TYPE to l_sbData\r
+ put l_sMode to l_sbData at DW_TYPE.value\r
+ getaddress of l_sbData to l_pbData \r
+ \r
+ move (CryptSetKeyParam(l_hKey, KP_MODE, l_pbData, 0)) to l_iResult\r
+ \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end \r
+ \r
+ end_procedure\r
+ \r
+ function export_key returns string\r
+ local integer l_iResult\r
+ local string l_sData l_sDataSize\r
+ local handle l_hKey\r
+ local pointer l_pData l_pDataSize\r
+ local integer l_iKeyBlobSize l_iDataSize\r
+ \r
+ get c_hKey to l_hKey\r
+ \r
+ if (l_hKey <> 0) begin\r
+ zerotype _PLAINTEXTKEYBLOB to l_sData\r
+ getaddress of l_sData to l_pData\r
+ \r
+ zerotype _DW_TYPE to l_sDataSize\r
+ put (length(l_sData)) to l_sDataSize at DW_TYPE.value\r
+ getaddress of l_sDataSize to l_pDataSize\r
+ \r
+ move (CryptExportKey(l_hKey, 0, PLAINTEXTKEYBLOB, 0, l_pData, l_pDataSize)) to l_iResult\r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptExportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end \r
+ \r
+ getbuff from l_sDataSize at DW_TYPE.value to l_iKeyBlobSize\r
+ getbuff from l_sData at PLAINTEXTKEYBLOB.dwKeySize to l_iDataSize\r
+ move (mid(l_sData,l_iDataSize,13)) to l_sData\r
+ \r
+ if (show_debug_lines) begin\r
+ showln "DEBUG: Key blob Size = " l_iKeyBlobSize \r
+ end\r
+ end\r
+ function_return l_sData\r
+ end_function\r
+ \r
+ function encrypt_decrypt string in_data integer in_decrypt returns string\r
+ local integer l_iResult l_iDataSize\r
+ local string l_sData l_sDataSize\r
+ local pointer l_pData l_pDataSize \r
+ local handle l_hKey\r
+ \r
+ move in_data to l_sData \r
+ get c_hKey to l_hKey\r
+ \r
+ zerotype _DW_TYPE to l_sDataSize\r
+ put (length(l_sData)) to l_sDataSize at DW_TYPE.value\r
+ getaddress of l_sDataSize to l_pDataSize \r
+ \r
+ move (l_sData+repeat(' ',length(l_sData)*2)) to l_sData\r
+ getaddress of l_sData to l_pData \r
+ \r
+ if (in_decrypt = 0) move (CryptEncrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize, length(l_sData))) to l_iResult\r
+ else move (CryptDecrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize)) to l_iResult \r
+\r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: " (ternary(in_decrypt = 0, "CryptEncrypt", "CryptDecrypt")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end\r
+ \r
+ getbuff from l_sDataSize at DW_TYPE.value to l_iDataSize\r
+ move (cstring(mid(l_sData,l_iDataSize,1))) to l_sData\r
+ \r
+ function_return l_sData\r
+ end_function\r
+ \r
+ function encrypt string in_data returns string\r
+ local string l_sData\r
+ \r
+ get encrypt_decrypt in_data 0 to l_sData\r
+ function_return l_sData\r
+ end_function\r
+ \r
+ function decrypt string in_data returns string\r
+ local string l_sData\r
+ \r
+ get encrypt_decrypt in_data 1 to l_sData\r
+ function_return l_sData\r
+ end_function\r
+ \r
+ procedure destroy_key\r
+ local integer l_iResult\r
+ local handle l_hKey l_hHash\r
+ \r
+ get c_hKey to l_hKey\r
+ \r
+ if (l_hKey <> 0) begin\r
+ move (CryptDestroyKey(l_hKey)) to l_iResult \r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: CryptDestroyKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError())) \r
+ end \r
+ else begin\r
+ set c_hKey to 0\r
+ set c_sAlg to ""\r
+ end\r
+ end\r
+ \r
+ get c_hHash to l_hHash\r
+ if (l_hHash <> 0) send destroy_hash \r
+ \r
+ end_procedure\r
+ \r
+ procedure release_context\r
+ local integer l_iResult\r
+ local handle l_hProv \r
+ \r
+ get c_hProv to l_hProv\r
+ \r
+ if (l_hProv <> 0) begin \r
+ move (CryptReleaseContext(l_hProv, 0)) to l_iResult\r
+ if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
+ showln "ERROR: Cryptrelease_context " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
+ end \r
+ else set c_hProv to 0\r
+ end\r
+ \r
+ end_procedure\r
+ \r
+ procedure destory_object\r
+ local handle l_hProv l_hHash l_hKey\r
+ \r
+ get c_hKey to l_hKey\r
+ if (l_hKey <> 0) send destroy_key\r
+ \r
+ get c_hHash to l_hHash\r
+ if (l_hHash <> 0) send destroy_hash\r
+ \r
+ get c_hProv to l_hProv\r
+ if (l_hProv <> 0) send release_context\r
+ \r
+ forward send destory_object\r
+ end_procedure\r
+ \r
+end_class\r
+\r
+//-------------------------------------------------------------------------\r
+// Functions\r
+//-------------------------------------------------------------------------\r
+\r
+// Used for procedural invocations of hashing and encrypting\r
+object msAdvCrypt_global_obj is an msAdvCrypt\r
+end_object\r
+\r
+// Procedural one-shot use of msAdvCrypt hashing\r
+function msAdvCrypt_hash global string in_data string in_hash returns string\r
+ local string l_sReturn\r
+ \r
+ send aquire_context to msAdvCrypt_global_obj\r
+ get make_hash of msAdvCrypt_global_obj in_data in_hash to l_sReturn\r
+ send destroy_hash to msAdvCrypt_global_obj\r
+ send release_context to msAdvCrypt_global_obj\r
+ \r
+ function_return l_sReturn\r
+end_function\r
+\r
+function sha512_hex global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'HEX'))\r
+end_function\r
+\r
+function sha512_base64 global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'BASE64'))\r
+end_function\r
+\r
+function sha384_hex global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'HEX'))\r
+end_function\r
+\r
+function sha384_base64 global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'BASE64'))\r
+end_function\r
+\r
+function sha256_hex global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'HEX'))\r
+end_function\r
+\r
+function sha256_base64 global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'BASE64'))\r
+end_function\r
+\r
+function sha1_hex global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'HEX'))\r
+end_function\r
+\r
+function sha1_base64 global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'BASE64'))\r
+end_function\r
+\r
+function md5_hex global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'HEX'))\r
+end_function\r
+\r
+function md5_base64 global string in_data returns string\r
+ function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'BASE64'))\r
+end_function\r
+\r
+// Procedural one-shot use of msAdvCrypt AES256 encryption (HEX)\r
+function aes256_hex_enc global string in_data string in_key returns string\r
+ local string l_sReturn l_sBuf\r
+ \r
+ send aquire_context to msAdvCrypt_global_obj\r
+ \r
+ send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"\r
+ send modify_key_mode to msAdvCrypt_global_obj "CBC"\r
+ \r
+ get generate_random_key_iv of msAdvCrypt_global_obj to l_sBuf \r
+ move l_sBuf to l_sReturn\r
+ \r
+ get encrypt of msAdvCrypt_global_obj in_data to l_sBuf\r
+ append l_sReturn l_sBuf\r
+ \r
+ send destroy_key to msAdvCrypt_global_obj \r
+ send release_context to msAdvCrypt_global_obj\r
+ \r
+ function_return (binary_to_string(l_sReturn,"HEX"))\r
+end_function\r
+\r
+// Procedural one-shot use of msAdvCrypt AES256 decryption (HEX)\r
+function aes256_hex_dec global string in_data string in_key returns string\r
+ local string l_sReturn l_sBuf\r
+ \r
+ move (string_to_binary(in_data,"HEX")) to l_sBuf\r
+ \r
+ send aquire_context to msAdvCrypt_global_obj \r
+ send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"\r
+ send modify_key_mode to msAdvCrypt_global_obj "CBC"\r
+ \r
+ send modify_key_iv to msAdvCrypt_global_obj (mid(l_sBuf,16,1))\r
+ \r
+ get decrypt of msAdvCrypt_global_obj (mid(l_sBuf,length(l_sBuf)-16,17)) to l_sReturn\r
+ \r
+ send destroy_key to msAdvCrypt_global_obj \r
+ send release_context to msAdvCrypt_global_obj\r
+ \r
+ function_return l_sReturn\r
+end_function\r