1 //-------------------------------------------------------------------------
\r
3 // This file contains DataFlex functions to provide wrappers around "Win32"
\r
4 // API calls. See win32.h for external function definitions.
\r
6 // This file is to be included when using Win32 capabilities in df32func.mk
\r
8 // Copyright (c) 2006-2015, glyn@8kb.co.uk
\r
10 // df32func/win32.inc
\r
11 //-------------------------------------------------------------------------
\r
18 //-------------------------------------------------------------------------
\r
20 //-------------------------------------------------------------------------
\r
22 // Takes both the high-order doubleword and low-order doubleword representing the date&time 2X32bit numbers
\r
23 // and returns as a string
\r
24 function convert_date_format global dword dwLowDateTime dword dwHighDateTime returns string
\r
25 local string sftTime sSystemTime sFormattedTime sFormattedDate sLocalFileTime
\r
26 local pointer lpsftTime lpsSystemTime lpsFormattedTime lpsFormattedDate lpsLocalFileTime
\r
27 local integer iSuccess iLenCcTime iDataLength iLenCcDate
\r
29 zerotype _FILETIME to sftTime
\r
30 put dwLowDateTime to sftTime at FILETIME.dwLowDateTime
\r
31 put dwHighDateTime to sftTime at FILETIME.dwHighDateTime
\r
32 getaddress of sftTime to lpsftTime
\r
34 zeroType _FILETIME to sLocalFileTime
\r
35 getaddress of sLocalFileTime to lpsLocalFileTime
\r
37 move (FileTimeToLocalFileTime(lpsftTime,lpsLocalFileTime)) to iSuccess
\r
38 if (iSuccess <> 0) begin
\r
39 zerotype _SYSTEMTIME to sSystemTime
\r
40 getaddress of sSystemTime to lpsSystemTime
\r
42 move (FileTimeToSystemTime(lpsLocalFileTime,lpsSystemTime)) to iSuccess
\r
43 if (iSuccess <> 0) begin
\r
44 zerostring 255 to sFormattedTime
\r
45 getaddress of sFormattedTime to lpsFormattedTime
\r
46 move (length(sFormattedTime)) to iLenCcTime
\r
47 move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, lpsSystemTime, 0, lpsFormattedTime, iLenCcTime)) to iDataLength
\r
49 zerostring 255 To sFormattedDate
\r
50 getaddress of sFormattedDate To lpsFormattedDate
\r
51 move (length(sFormattedDate)) to iLenCcDate
\r
52 move (GetDateFormat("LOCALE_USER_DEFAULT", 0, lpsSystemTime, 0, lpsFormattedDate, iLenCcDate)) to iDataLength
\r
53 function_return (cstring (sFormattedDate) * cstring (sFormattedTime)) // return with terminating null char removed
\r
58 // List directory takes a directory path and returns a file count-1
\r
59 // file listing information including size is put into 5 global arrays
\r
61 // Returns an integer file_count-1, where count represents the number of files found in the directory.
\r
62 // I.e. If no files are found it will return -1, if one file is found it will return 0
\r
63 // If files are found, attributes of the files can be found in the following global arrays:
\r
65 // Win32API_result1 - File Name
\r
66 // Win32API_result2 - File Size
\r
67 // Win32API_result3 - Modified Date
\r
68 // Win32API_result4 - Access Date
\r
69 // Win32API_result5 - Creation Date
\r
71 function list_directory global string argv returns string
\r
72 local string sPathName sWin32FindData sLine sLast sComment sFileName sModifiedDate sAccessDate sCreationDate k sLastFile
\r
73 local integer l_01iResult iFileSize iFileCount
\r
74 local pointer pT5 pT6
\r
76 local dword dwFileSizeHigh dwFileSizeLow dwHighDateTime dwLowDateTime
\r
78 send delete_data to Win32API_result1
\r
79 send delete_data to Win32API_result2
\r
80 send delete_data to Win32API_result3
\r
81 send delete_data to Win32API_result4
\r
82 send delete_data to Win32API_result5
\r
84 zerotype _WIN32_FIND_DATA to sWin32FindData
\r
85 getaddress of sWin32FindData to pT5
\r
86 move argv to sPathName
\r
87 getaddress of sPathName to pT6
\r
88 move (FindFirstFile(pT6, pT5)) to hFile
\r
89 // if (hFile = -1) showln "Invalid file handle!"
\r
91 move -1 to iFileCount
\r
94 getbuff_String from sWin32FindData at WIN32_FIND_DATA.cFileName to sFileName
\r
95 if ((sFileName <> ".") and (sFileName <> "..") and (sFileName <> "")) begin
\r
96 increment iFileCount
\r
99 getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeHigh to dwFileSizeHigh
\r
100 getbuff from sWin32FindData at WIN32_FIND_DATA.nFileSizeLow to dwFileSizeLow
\r
101 moveint ((dwFileSizeHigh*MaxDword)+dwFileSizeLow) to iFileSize
\r
103 // File Modified Time
\r
104 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteLowDateTime to dwLowDateTime
\r
105 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastWriteHighDateTime to dwHighDateTime
\r
106 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sModifiedDate
\r
108 // File Accessed Time
\r
109 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessLowDateTime to dwLowDateTime
\r
110 getbuff from sWin32FindData at WIN32_FIND_DATA.ftLastAccessHighDateTime to dwHighDateTime
\r
111 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sAccessDate
\r
113 // File Creation Time
\r
114 getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationLowDateTime to dwLowDateTime
\r
115 getbuff from sWin32FindData at WIN32_FIND_DATA.ftCreationHighDateTime to dwHighDateTime
\r
116 move (convert_date_format(dwLowDateTime, dwHighDateTime)) to sCreationDate
\r
118 set array_value of (Win32API_result1(current_object)) item iFileCount to sFileName
\r
119 set array_value of (Win32API_result2(current_object)) item iFileCount to iFileSize
\r
120 set array_value of (Win32API_result3(current_object)) item iFileCount to sModifiedDate
\r
121 set array_value of (Win32API_result4(current_object)) item iFileCount to sAccessDate
\r
122 set array_value of (Win32API_result5(current_object)) item iFileCount to sCreationDate
\r
124 zerotype _WIN32_FIND_DATA to sWin32FindData
\r
125 move (FindNextFile(hFile, pT5)) to l_01iResult
\r
126 until (l_01iResult = 0)
\r
127 move (FindClose(hFile)) to l_01iResult
\r
129 function_return iFileCount
\r
132 // Sort a directory listing
\r
133 // argv = array to sort by 1-6, argv2 = array size
\r
134 // Returns the the data array size
\r
135 function sort_results global integer argv integer argv2 returns integer
\r
136 local integer doneSort l_i l_j l_h l_tmpInt
\r
137 local number l_tmpNum
\r
138 local string l_tmpStr l_tmpStr2
\r
139 local date l_tmpDate
\r
141 send delete_data to Win32API_sort
\r
142 send delete_data to Win32API_sort1
\r
143 send delete_data to Win32API_sort2
\r
144 send delete_data to Win32API_sort3
\r
145 send delete_data to Win32API_sort4
\r
146 send delete_data to Win32API_sort5
\r
147 send delete_data to Win32API_sort6
\r
150 if ((argv < 1) or (argv > 5)) goto sorted
\r
152 for l_i from 0 to argv2
\r
153 if (argv = 1) get string_value of (Win32API_result1(current_object)) item l_i to l_tmpStr
\r
154 if (argv = 2) get integer_value of (Win32API_result2(current_object)) item l_i to l_tmpInt
\r
155 if (argv = 3) get string_value of (Win32API_result3(current_object)) item l_i to l_tmpStr
\r
156 if (argv = 4) get string_value of (Win32API_result4(current_object)) item l_i to l_tmpStr
\r
157 if (argv = 5) get string_value of (Win32API_result5(current_object)) item l_i to l_tmpStr
\r
159 if (argv = 1) begin
\r
160 if ((trim(l_tmpStr)) = "") move "NULL" to l_tmpStr
\r
161 set array_value of (Win32API_sort(current_object)) item l_i to (string(lowercase(l_tmpStr)))
\r
163 if (argv = 2) set array_value of (Win32API_sort(current_object)) item l_i to l_tmpInt
\r
164 if (argv > 2) begin
\r
165 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
166 set array_value of (Win32API_sort(current_object)) item l_i to l_tmpNum
\r
167 set array_value of (Win32API_sort6(current_object)) item l_i to l_tmpNum
\r
171 send sort_items to Win32API_sort ascending
\r
173 for l_i from 0 to argv2
\r
174 get string_value of (Win32API_sort(current_object)) item l_i to l_tmpStr
\r
175 if ((trim(uppercase(l_tmpStr))) <> "NULL") begin
\r
176 for l_j from 0 to argv2
\r
177 if (argv = 1) get string_value of (Win32API_result1(current_object)) item l_j to l_tmpStr2
\r
178 if (argv = 2) get string_value of (Win32API_result2(current_object)) item l_j to l_tmpStr2
\r
179 if (argv > 2) get string_value of (Win32API_sort6(current_object)) item l_j to l_tmpStr2
\r
181 if (((trim(l_tmpStr2)) <> "NULL") and ((trim(l_tmpStr2)) <> "")) begin
\r
182 if ((trim(lowercase(l_tmpStr))) = (trim(lowercase(l_tmpStr2)))) begin
\r
183 get string_value of (Win32API_result1(current_object)) item l_j to l_tmpStr
\r
184 set array_value of (Win32API_sort1(current_object)) item l_i to l_tmpStr
\r
185 get integer_value of (Win32API_result2(current_object)) item l_j to l_tmpInt
\r
186 set array_value of (Win32API_sort2(current_object)) item l_i to l_tmpInt
\r
187 get string_value of (Win32API_result3(current_object)) item l_j to l_tmpStr
\r
188 set array_value of (Win32API_sort3(current_object)) item l_i to l_tmpStr
\r
189 get string_value of (Win32API_result4(current_object)) item l_j to l_tmpStr
\r
190 set array_value of (Win32API_sort4(current_object)) item l_i to l_tmpStr
\r
191 get string_value of (Win32API_result5(current_object)) item l_j to l_tmpStr
\r
192 set array_value of (Win32API_sort5(current_object)) item l_i to l_tmpStr
\r
194 if (argv = 1) set array_value of (Win32API_result1(current_object)) item l_j to "NULL"
\r
195 if (argv = 2) set array_value of (Win32API_result2(current_object)) item l_j to "NULL"
\r
196 if (argv > 2) set array_value of (Win32API_sort6(current_object)) item l_j to "NULL"
\r
204 for l_i from 0 to argv2
\r
205 get string_value of (Win32API_sort1(current_object)) item l_i to l_tmpStr
\r
206 set array_value of (Win32API_result1(current_object)) item l_i to l_tmpStr
\r
207 get string_value of (Win32API_sort2(current_object)) item l_i to l_tmpInt
\r
208 set array_value of (Win32API_result2(current_object)) item l_i to l_tmpInt
\r
209 get string_value of (Win32API_sort3(current_object)) item l_i to l_tmpStr
\r
210 set array_value of (Win32API_result3(current_object)) item l_i to l_tmpStr
\r
211 get string_value of (Win32API_sort4(current_object)) item l_i to l_tmpStr
\r
212 set array_value of (Win32API_result4(current_object)) item l_i to l_tmpStr
\r
213 get string_value of (Win32API_sort5(current_object)) item l_i to l_tmpStr
\r
214 set array_value of (Win32API_result5(current_object)) item l_i to l_tmpStr
\r
217 send delete_data to Win32API_sort
\r
218 send delete_data to Win32API_sort1
\r
219 send delete_data to Win32API_sort2
\r
220 send delete_data to Win32API_sort3
\r
221 send delete_data to Win32API_sort4
\r
222 send delete_data to Win32API_sort5
\r
225 function_return doneSort
\r
228 // This function allows basic file operations delete, move, copy, rename
\r
229 // Useful where DataFlex internal functionssuch as erasefile or copyfile are flakey.
\r
231 // fileOpp(<operation type>,<source file>,<dest file>)
\r
232 // <operation name> can be any of "COPY", "DELETE", "MOVE" or "RENAME"
\r
236 // fileOpp("delete","C:\FileTo.delete","")
\r
237 // fileOpp("move","C:\Source.file","C:\Destination.file")
\r
239 function fileopp global string argv string argv2 string argv3 returns integer
\r
240 local string sFileOp
\r
241 local pointer lpFileOp lpArgv2 lpArgv3
\r
242 local integer l_iResult
\r
244 move 0 to l_iResult
\r
245 move (trim(uppercase(argv))) to argv
\r
246 move (trim(argv2)) to argv2
\r
247 move (trim(argv3)) to argv3
\r
249 if (((argv = "COPY") or (argv = "PRINT") or (argv = "DELETE") or (argv = "MOVE") or (argv = "RENAME")) and (argv2 <> "")) begin
\r
250 zerotype _SHFILEOPSTRUCT to sFileOp
\r
251 getaddress of sFileOp to lpFileOp
\r
254 case (argv = "COPY") put FO_COPY to sFileOp at SHFILEOPSTRUCT.wFunc
\r
256 case (argv = "PRINT") put FO_COPY to sFileOp at SHFILEOPSTRUCT.wFunc
\r
258 case (argv = "DELETE") put FO_DELETE to sFileOp at SHFILEOPSTRUCT.wFunc
\r
260 case (argv = "MOVE") put FO_MOVE to sFileOp at SHFILEOPSTRUCT.wFunc
\r
262 case (argv = "RENAME") put FO_RENAME to sFileOp at SHFILEOPSTRUCT.wFunc
\r
266 move (argv2+character(0)+character(0)) to argv2
\r
267 move (argv3+character(0)+character(0)) to argv3
\r
268 getAddress of argv2 to lpArgv2
\r
269 put lpArgv2 to sFileOp at SHFILEOPSTRUCT.pFrom
\r
271 if (argv <> "DELETE") begin
\r
272 getAddress Of argv3 to lpArgv3
\r
273 put lpArgv3 to sFileOp at SHFILEOPSTRUCT.pTo
\r
277 case (argv = "PRINT") put (FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT+FOF_NOERRORUI+FOF_NOCOPYSECURITYATTRIBS) to sFileOp at SHFILEOPSTRUCT.fFlags
\r
279 case else put (FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT+FOF_NOERRORUI) to sFileOp at SHFILEOPSTRUCT.fFlags
\r
283 // put ? to sFileOp at SHFILEOPSTRUCT.hWnd
\r
284 // put ? to sFileOp at SHFILEOPSTRUCT.fAnyOperationsAborted
\r
285 // put ? to sFileOp at SHFILEOPSTRUCT.hNameMappings
\r
286 // put ? to sFileOp at SHFILEOPSTRUCT.lpszProgressTitle
\r
288 move (SHFileOperation(lpFileOp)) to l_iResult
\r
291 function_return l_iResult
\r
294 // Get temp dir on local machine from windows registry
\r
295 function get_local_temp global integer argv returns string
\r
296 local string lpBuffer
\r
297 local integer l_01iResult
\r
298 local pointer tmpPtr
\r
300 move (pad(lpBuffer,255)) to lpBuffer // this is a hack to allocate a specific size to a local string
\r
301 getaddress of lpBuffer to tmpPtr
\r
302 move (GetTempPath(255,tmpPtr)) to l_01iResult
\r
304 function_return lpbuffer
\r
307 // Get system dir on local machine from windows registry
\r
308 function get_local_system global integer argv returns string
\r
309 local string sBuffer
\r
310 local pointer lpBuffer l_iResult uSize
\r
313 move (repeat(character(0),(uSize+1))) to sBuffer
\r
314 getAddress of sBuffer to lpBuffer
\r
315 move (GetSystemDirectory(lpBuffer,uSize)) to l_iResult
\r
317 function_return (left(sBuffer,l_iResult))
\r
320 // Function to open close cd tray dll - 0 to open 1 to close
\r
321 function cd_tray global integer argv returns integer
\r
322 local integer l_iResult
\r
323 local string l_sReturn l_sCmd
\r
324 local pointer l_pCmd l_pReturn
\r
326 zerostring 127 to l_sCmd
\r
327 getaddress of l_sCmd to l_pCmd
\r
328 getaddress of l_sReturn to l_pReturn
\r
330 if (argv = 0) move "set CDAudio door open" to l_sCmd
\r
331 if (argv = 1) move "set CDAudio door closed" to l_sCmd
\r
332 move (mciSendString(l_pCmd,l_pReturn,127,0)) to l_iResult
\r
334 function_return l_sReturn
\r
337 // This function will force dataflex to exit with the error code in iReturnCode
\r
338 function exit_process global integer iReturnCode returns integer
\r
339 local integer iVoid
\r
341 move (ExitProcessEx(iReturnCode)) To iVoid
\r
343 function_return iVoid
\r
346 // Grab the process ID of dfruncon
\r
347 function get_process_id global integer argv returns integer
\r
348 local integer iRVal
\r
350 move (GetPID()) TO iRVal
\r
352 function_return (Low(iRVal))
\r
355 // Grab the computername
\r
356 function get_computer global integer argv returns string
\r
357 local string strName lsSize
\r
358 local pointer lpNameAddr lpSize
\r
359 local integer l_01iResult
\r
361 move (repeat(character(0),255)) to strName
\r
362 getAddress of strName to lpNameAddr
\r
363 move (repeat(character(0),_SIZEGETCOMPUTERNAME_SIZE)) to lsSize
\r
364 put 16 to lsSize at SIZEGETCOMPUTERNAME.dwSize
\r
365 getAddress of lsSize to lpSize
\r
366 move (GetComputername(lpNameAddr, lpSize )) to l_01iResult
\r
368 if (l_01iResult) function_return (cstring(strName)) // return with terminating null char removed
\r
369 else function_return "Unknown"
\r
372 // Grab the windows username
\r
373 function get_user_name global integer argv returns string
\r
374 local string strName
\r
375 local pointer lpNameAddr
\r
376 local integer l_01iResult
\r
378 move (repeat(character(0),255)) to strName
\r
379 getAddress of strName to lpNameAddr
\r
380 move (WNetGetUser(0, lpNameAddr, DWORDtoBytes(255))) to l_01iResult
\r
381 if (l_01iResult = 0) function_return (uppercase(cstring(strName))) // return with terminating null char removed
\r
382 else function_return "Unknown"
\r
385 // Use a standard windows folder browser, takes the title of the browser, returns the file path
\r
386 function folder_browse global string argv returns String
\r
387 local string sFolder sBrowseInfo sTitle
\r
388 local pointer lpItemIdList lpsFolder lpsBrowseInfo lpsTitle
\r
389 integer iFolderSelected l_iRetval
\r
391 zeroType _BROWSEINFO to sBrowseInfo
\r
393 if (argv<>"") begin
\r
394 move argv to sTitle
\r
395 getAddress of sTitle to lpsTitle
\r
396 put lpsTitle to sBrowseInfo at BROWSEINFO.lpszTitle
\r
399 put BIF_RETURNONLYFSDIRS+BIF_EDITBOX+BIF_BROWSEINCLUDEFILES to sBrowseInfo At BROWSEINFO.ulFlags
\r
400 // put (window_handle(focus(desktop))) to sBrowseInfo At BROWSEINFO.hWndOwner ??
\r
401 move (repeat(character(0),260)) to sFolder // set the size of sFolder to 128 by nulling in 8 chars
\r
403 getAddress Of sBrowseInfo to lpsBrowseInfo
\r
404 getAddress Of sFolder to lpsFolder
\r
406 move (SHBrowseForFolder(lpsBrowseInfo)) to lpItemIdList // select folder
\r
407 move (SHGetPathFromIDList(lpItemIdList, lpsFolder)) to iFolderSelected // get folder name
\r
408 move (CoTaskMemFree(lpItemIdList)) to l_iRetval // release memory used by ItemIdList
\r
410 if (iFolderSelected = 0) move "" to sFolder
\r
412 function_return (cString(sFolder)) // return with terminating null char removed
\r
415 // Function to convert a long filename into a windows short filename
\r
416 function get_short_path global string argv returns string
\r
417 local string sShortPath sLongPath
\r
418 local pointer lpszShortPath lpszLongPath
\r
419 local integer cchBuffer l_iResult
\r
421 move (trim(argv)) to sLongPath
\r
422 move 255 to cchBuffer
\r
423 move (repeat(character(0),(cchBuffer+1))) to sShortPath
\r
424 getaddress of sLongPath to lpszLongPath
\r
425 getaddress of sShortPath to lpszShortPath
\r
426 move (GetShortPathName(lpszLongPath,lpszShortPath,cchBuffer)) to l_iResult
\r
428 function_return (left(sShortPath,l_iResult))
\r
431 // Set of function to disable close widgets of shell
\r
432 function disable_close global integer argv returns integer
\r
434 local handle hWnd hMenu
\r
436 if (g_sConsoleTitleIsSet <> "DataFlex") begin
\r
437 // change the window title so we can find the window
\r
438 move (SetConsoleTitle("DataFlex")) to strmark
\r
439 move "DataFlex" to g_sConsoleTitleIsSet
\r
440 // Give SetConsoleTitle a chance to take effect
\r
445 move (FindWindow(0, "DataFlex")) to hWnd
\r
447 move (GetSystemMenu(hWnd, 0)) to hMenu
\r
449 if (argv = 0) move (EnableMenuItem(hMenu, SC_CLOSE, (MF_BYCOMMAND ior MF_GRAYED))) to ret
\r
451 if (argv = 1) move (EnableMenuItem(hMenu, SC_CLOSE, (MF_BYCOMMAND ior MF_ENABLED))) to ret
\r
456 // This function will run any external application directly from dataflex
\r
457 // argv = application to run (command name/path) argv2 = any parameters to pass to the program argv3 = directory to run from
\r
458 function shell_exec global string argv string argv2 string argv3 returns integer
\r
459 local handle windowHandle
\r
460 local pointer lpOperation lpFile lpParameters lpDirectory
\r
461 local integer nShowCmd l_iResult
\r
462 local string sOperation sFile sParameters sDirectory
\r
464 if ((trim(argv)) <> "") begin
\r
465 move 0 to windowHandle
\r
466 move "open" to sOperation
\r
468 if ((trim(argv2)) <> "") move argv2 to sParameters
\r
469 else move "" to sParameters
\r
470 if ((trim(argv3)) <> "") move argv3 to sDirectory
\r
471 else move "" to sDirectory
\r
472 move "" to sDirectory
\r
474 getAddress of sOperation to lpOperation
\r
475 getAddress of sFile to lpFile
\r
476 getAddress of sParameters to lpParameters
\r
477 getAddress of sDirectory to lpDirectory
\r
479 move (ShellExecute(windowHandle,lpOperation,lpFile,lpParameters,lpDirectory,SW_SHOWMAXIMIZED)) to l_iResult
\r
483 // This function will run the console application stated in argv1
\r
484 // argv2 = set to 1 to run the process in a new window
\r
485 // argv3 = set to 1 to leave the new process running and continue without killing it
\r
486 // argv4 = The time to live before killing the process - set to zero to wait until finished
\r
487 // Note - Setting argv3 to 1 will result in build up of open handles for finished processes
\r
488 // if term_proc is not used to terminate the process.
\r
489 // It is possible to have multiple processes running in one window by
\r
490 // setting argv2 = 0 and argv3 = 1, but handling how they behave on the screen
\r
491 // requires some careful fiddling.
\r
492 function create_proc global string argv integer argv2 integer argv3 integer argv4 returns string
\r
493 local pointer lpProcessInformation lpStartupInformation
\r
494 local integer l_iResult
\r
495 local pointer lpApplicationName lpCommandLine lpProcessAttributes lpThreadAttributes lpEnvironment lpCurrentDirectory
\r
496 local integer bInheritHandles iProcessAttributes iThreadAttributes iEnvironment
\r
497 local dword dwCreationFlags dwMilliseconds
\r
498 local string sProcessInformation sStartupInformation sApplicationName sCommandLine sCurrentDirectory l_sExit l_sTmp
\r
499 local handle hProcess hThread
\r
501 zeroType _PROCESS_INFORMATION to sProcessInformation
\r
502 zeroType _STARTUPINFO to sStartupInformation
\r
504 move STRINGNULL to l_sExit
\r
505 move STRINGNULL to sApplicationName
\r
506 move argv to sCommandLine
\r
507 move HEXNULL to iProcessAttributes
\r
508 move HEXNULL to iThreadAttributes
\r
509 move HEXTRUE to bInheritHandles
\r
510 move HEXNULL to iEnvironment
\r
511 move STRINGNULL to sCurrentDirectory
\r
512 if (argv2 = 0) move NORMAL_PRIORITY_CLASS to dwCreationFlags
\r
513 if (argv2 = 1) move (CREATE_NEW_CONSOLE+NORMAL_PRIORITY_CLASS) to dwCreationFlags
\r
515 getaddress of sApplicationName to lpApplicationName
\r
516 getaddress of sCommandLine to lpCommandLine
\r
517 getaddress of iProcessAttributes to lpProcessAttributes
\r
518 getaddress of iThreadAttributes to lpThreadAttributes
\r
519 getaddress of iEnvironment to lpEnvironment
\r
520 getaddress of sCurrentDirectory to lpCurrentDirectory
\r
521 getaddress of sProcessInformation to lpProcessInformation
\r
522 getaddress of sStartupInformation to lpStartupInformation
\r
524 put (length(sStartupInformation)) to sStartupInformation at STARTUPINFO.cb
\r
526 move (CreateProcess(lpApplicationName,lpCommandLine,lpProcessAttributes,lpThreadAttributes,dwCreationFlags,dwCreationFlags,lpEnvironment,lpCurrentDirectory,lpStartupInformation,lpProcessInformation)) to l_iResult
\r
528 getbuff from sProcessInformation at PROCESS_INFORMATION.hProcess to hProcess
\r
529 getbuff from sProcessInformation at PROCESS_INFORMATION.hThread to hThread
\r
531 if (argv3 <> 1) begin
\r
532 if (argv4 = 0) move INFINITE to dwMilliseconds
\r
533 if (argv4 <> 0) move argv4 to dwMilliseconds
\r
534 move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult
\r
535 move (TerminateProcess(hProcess,HEXNULL)) to l_iResult
\r
536 move (CloseHandle(hThread)) to l_iResult
\r
537 move (CloseHandle(hProcess)) to l_iResult
\r
539 if (argv3 = 1) begin
\r
540 move hProcess to l_sExit
\r
541 append l_sExit "|" hThread
\r
544 function_return l_sExit
\r
547 // This will terminate a process started in create_proc with argv3 set to 1
\r
548 // move the string returned by create_proc to argv
\r
549 // set argv2 to 0 if you want to wait for the process to finish before terminating
\r
550 // set argv2 to 1 if you want to terminate the process without waiting for it to finish
\r
551 function term_proc global string argv integer argv2 returns integer
\r
552 local integer l_iSuccess
\r
553 local integer dwMilliseconds l_iResult
\r
554 local handle hProcess hThread
\r
556 move 0 to l_iSuccess
\r
557 move (trim(argv)) to argv
\r
558 if ((argv contains "|") and ((length(argv)) >= 3)) begin
\r
559 move (left(argv,(pos("|",argv)-1))) to hProcess
\r
560 move (mid(argv,(length(argv)-pos("|",argv)),(pos("|",argv)+1))) to hThread
\r
561 move INFINITE to dwMilliseconds
\r
562 if (argv2 = 0) move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult
\r
563 move (TerminateProcess(hProcess,HEXNULL)) to l_iResult
\r
564 move (CloseHandle(hThread)) to l_iResult
\r
565 move (CloseHandle(hProcess)) to l_iResult
\r
568 function_return l_iSuccess
\r
571 // Check if a file is locked by a windows process
\r
572 // Returns 1 if the file is locked.
\r
573 function is_locked global string argv returns integer
\r
574 local integer l_iResult l_iDllErr l_iThrow
\r
575 local handle l_hFile
\r
576 move 0 to l_iResult
\r
578 move (trim(argv)) to argv
\r
579 if (argv <> "") begin
\r
580 move (lOpen(argv,(OF_READ+OF_SHARE_EXCLUSIVE))) to l_hFile
\r
581 move (GetLastError()) to l_iDllErr
\r
582 if ((l_hFile = -1) and (l_iDllErr = 32)) move 1 to l_iResult
\r
583 if (l_hFile <> -1) begin
\r
584 move (lClose(l_hFile)) to l_iThrow
\r
587 function_return l_iResult
\r
590 // Check if a file exists. Returns 1 if the file exists.
\r
591 function does_exist global string argv returns integer
\r
592 local integer l_iResult l_iDllErr l_iThrow
\r
593 local handle l_hFile
\r
594 move 0 to l_iResult
\r
596 move (trim(argv)) to argv
\r
597 if (argv <> "") begin
\r
598 move 1 to l_iResult
\r
599 move (lOpen(argv,(OF_READ+OF_SHARE_DENY_NONE))) to l_hFile
\r
600 move (GetLastError()) to l_iDllErr
\r
601 if ((l_hFile = -1) and (l_iDllErr = 2)) move 0 to l_iResult
\r
602 if (l_hFile <> -1) begin
\r
603 move (lClose(l_hFile)) to l_iThrow
\r
606 function_return l_iResult
\r
609 // Read a text file line by line into the buffer array "Win32API_buffer"
\r
610 // Returns an integer i-1 where i is the count of array elements/lines.
\r
612 // Ref: http:// msdn2.microsoft.com/en-us/library/aa365467.aspx
\r
613 function buffer_text_file global string argv string argv2 returns integer
\r
614 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
615 local handle l_hFileHandle l_hFile
\r
616 local pointer l_pFileName l_pBuf l_pBytesRead
\r
617 local integer l_iFileSize l_iThrow l_iBytesRead l_iBytesToRead l_i l_iDllErr l_iLines
\r
619 send delete_data to Win32API_buffer
\r
620 move -1 to l_iLines
\r
622 move (trim(argv)) to argv
\r
623 move (trim(argv2)) to argv2
\r
624 move -1 to l_hFileHandle
\r
625 move 0 to l_iBytesRead
\r
626 move 1 to l_iBytesToRead
\r
629 if (argv <> "") begin
\r
630 getaddress of argv to l_pFileName
\r
631 move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile
\r
632 move (GetFileSize(l_hFile,0)) to l_iFileSize
\r
633 for l_i from 1 to l_iFileSize
\r
634 // move (SetFilePointer(l_hFile,l_i,0,FILE_CURRENT)) to l_iThrow
\r
635 zerostring 1 to l_sBuf
\r
636 getaddress of l_sBuf to l_pBuf
\r
637 zerotype _STRUCTBYTESREAD to l_structBytesRead
\r
638 getaddress of l_structBytesRead to l_pBytesRead
\r
639 move (ReadFile(l_hFile,l_pBuf,l_iBytesToRead,l_pBytesRead,HexNull)) to l_iThrow
\r
640 getbuff from l_structBytesRead at STRUCTBYTESREAD.integer0 to l_iBytesRead
\r
641 if ((ascii(l_sBuf) = 10) or (ascii(l_sBuf) = 13) or ((argv2 <> "") and (argv2 = l_sBuf))) begin
\r
642 if (ascii(l_sBufL) <> 13) begin
\r
644 set array_value of (Win32API_buffer(current_object)) item l_iLines to l_sLine
\r
649 if ((ascii(l_sBuf) <> 10) and (ascii(l_sBuf) <> 13) and ((argv2 = "") or (argv2 <> l_sBuf))) append l_sLine l_sBuf
\r
650 move l_sBuf to l_sBufL
\r
652 move (CloseHandle(l_hFile)) to l_iThrow
\r
654 function_return l_iLines
\r
657 // Return file size in bytes from win32
\r
658 function file_size_bytes global string argv returns integer
\r
659 local integer l_iFileSize l_iThrow
\r
660 local pointer l_pFileName
\r
661 local handle l_hFile
\r
663 move -1 to l_iFileSize
\r
665 if (argv <> "") begin
\r
666 getaddress of argv to l_pFileName
\r
667 move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile
\r
668 move (GetFileSize(l_hFile,0)) to l_iFileSize
\r
669 move (CloseHandle(l_hFile)) to l_iThrow
\r
672 function_return l_iFileSize
\r
675 // Attempt to convert a string from unicode to ASCII/cp850 via WideCharToMultiByte
\r
676 // http:// msdn2.microsoft.com/en-us/library/ms776420.aspx
\r
677 function to_ascii global string argv returns string
\r
678 local string l_sAscii l_sUnicode
\r
679 local pointer l_pAscii l_pUnicode
\r
680 local integer l_iCharsNeeded l_iThrow
\r
681 move (trim(argv)) to l_sUnicode
\r
683 if (l_sUnicode <> "") begin
\r
684 zerostring (length(l_sUnicode)) to l_sAscii
\r
685 getAddress of l_sAscii to l_pAscii
\r
686 getAddress of l_sUnicode to l_pUnicode
\r
688 // set the length of cchWideChar to -1 and function assumes null termination and calculates length itsself
\r
689 move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,0,0,0,0)) to l_iCharsNeeded
\r
690 move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,l_pAscii,l_iCharsNeeded,0,0)) to l_iThrow
\r
692 function_return (cstring(l_sAscii))
\r
695 // Attempt to convert a string from ASCII to unicode via MultiByteToWideChar
\r
696 function to_unicode global string argv returns string
\r
697 local string l_sAscii l_sUnicode
\r
698 local pointer l_pAscii l_pUnicode
\r
699 local integer l_iCharsNeeded l_iThrow
\r
700 move (trim(argv)) to l_sAscii
\r
702 if (l_sAscii <> "") begin
\r
703 zerostring (length(l_sAscii)*2) to l_sUnicode
\r
704 getAddress of l_sUnicode to l_pUnicode
\r
705 getAddress of l_sAscii to l_pAscii
\r
707 // set the length of cchWideChar to -1 and function assumes null termination and calculates length itsself
\r
708 move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,0,0,0,0)) to l_iCharsNeeded
\r
709 move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow
\r
711 function_return (cstring(l_sUnicode))
\r
714 // Attempt to convert a string from ascii to UTF8 via WideCharToMultiByte
\r
715 function to_utf8 global string argv returns string
\r
716 local string l_sUTF8 l_sUnicode
\r
717 local pointer l_pUTF8 l_pUnicode
\r
718 local integer l_iCharsNeeded l_iThrow
\r
719 move (trim(argv)) to l_sUnicode
\r
721 if (l_sUnicode <> "") begin
\r
722 zerostring (length(l_sUnicode)) to l_sUTF8
\r
723 getAddress of l_sUTF8 to l_pUTF8
\r
724 getAddress of l_sUnicode to l_pUnicode
\r
726 // set the length of cchWideChar to -1 and function assumes null termination and calculates lenght itsself
\r
727 move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,0,0,0,0)) to l_iCharsNeeded
\r
728 move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow
\r
731 function_return (cstring(l_sUTF8))
\r
734 // https://msdn.microsoft.com/en-us/library/windows/desktop/ms647473%28v=vs.85%29.aspx
\r
735 // Note security considerations, as this function doesn't enforce string lengths
\r
736 function ansi_to_oem global string argv returns string
\r
737 local string l_sOem l_sAnsi
\r
738 local pointer l_pOem l_pAnsi
\r
739 local integer l_iResult
\r
741 if (length(argv) <> 0) begin
\r
742 move argv to l_sAnsi
\r
743 getaddress of l_sAnsi to l_pAnsi
\r
744 zerostring (length(l_sAnsi)+1) to l_sOem
\r
745 getaddress of l_sOem to l_pOem
\r
746 move (CharToOem(l_pAnsi, l_pOem)) to l_iResult
\r
749 move argv to l_sOem
\r
751 function_return (cstring(l_sOem))
\r
754 // https://msdn.microsoft.com/en-us/library/windows/desktop/ms647493%28v=vs.85%29.aspx
\r
755 // Note security considerations, as this function doesn't enforce string lengths
\r
756 function oem_to_ansi global string argv returns string
\r
757 local string l_sOem l_sAnsi
\r
758 local pointer l_pOem l_pAnsi
\r
759 local integer l_iResult
\r
761 if (length(argv) <> 0) begin
\r
762 move argv to l_sOem
\r
763 getaddress of l_sOem to l_pOem
\r
764 zerostring (length(l_sOem)+1) to l_sAnsi
\r
765 getaddress of l_sAnsi to l_pAnsi
\r
766 move (CharToOem(l_pOem, l_pAnsi)) to l_iResult
\r
769 move argv to l_sAnsi
\r
771 function_return (cstring(l_sAnsi))
\r
774 // Get running processes on the system
\r
775 // http:// msdn2.microsoft.com/en-us/library/ms682629.aspx
\r
776 // in progress - currently churns out list of process id's to screen
\r
777 function get_procs global integer argv returns integer
\r
778 local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules
\r
779 local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid
\r
780 local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules
\r
781 local handle l_hProcess
\r
783 move (1024*10) to l_iBytes
\r
784 zerostring l_iBytes to l_sProcesses
\r
785 move 0 to l_iBytesBack
\r
787 getAddress of l_sProcesses to l_pProcesses
\r
788 zerotype _STRUCTBYTESBACK to l_sStructBytesBack
\r
789 getaddress of l_sStructBytesBack to l_pBytesBack
\r
791 move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow
\r
793 getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack
\r
795 if (mod(l_iBytesBack,4) = 0) begin
\r
796 for l_i from 1 to (l_iBytesBack/4)
\r
797 move (left(l_sProcesses,4)) to l_sBuf
\r
798 move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses
\r
799 getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid
\r
800 move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess
\r
802 move 1024 to l_iBytes2
\r
803 zerostring l_iBytes2 to l_sModules
\r
804 getAddress of l_sModules to l_pModules
\r
805 zerotype _STRUCTBYTESBACK to l_sStructBytesBack
\r
806 getaddress of l_sStructBytesBack to l_pBytesBack2
\r
808 move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow
\r
809 getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2
\r
812 showln l_i " PROC=" l_iPid " BYTES=" l_iBytesBack2 " H=" l_hProcess " LERR=" (GetLastError())
\r
814 // showln l_iBytesBack2 " " l_hProcess
\r
815 if (mod(l_iBytesBack2,4) = 0) begin
\r
816 for l_j from 1 to (l_iBytesBack2/4)
\r
817 move (left(l_sModules,4)) to l_sBuf
\r
818 move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules
\r
819 getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid
\r
823 move (CloseHandle(l_hProcess)) to l_iThrow
\r
829 showln "BYTES " l_iBytesBack
\r
834 // Returns the current system time via the GetSystemTime call
\r
835 // Takes an integer value;
\r
836 // 1 - displays individual segments comma separated
\r
837 // 0 - displays a formatted date time
\r
838 function time_data global integer argv returns string
\r
839 local string sTimeData sResult sFormattedTime sFormattedDate
\r
840 local pointer pTimeData pFormattedTime pFormattedDate
\r
841 local integer iThrow iYear iMonth iDayOfWeek iDay iHour iMinute iSecond iMilliSeconds iLenCcTime iLenCcDate iDataLength
\r
843 zeroType _SYSTEMTIME to sTimeData
\r
844 getAddress of sTimeData to pTimeData
\r
845 move (GetSystemTime(pTimeData)) to iThrow
\r
847 // just return the structure comma separated
\r
848 if (argv = 1) begin
\r
849 getBuff from sTimeData at SYSTEMTIME.wYear to iYear
\r
850 getBuff from sTimeData at SYSTEMTIME.wMonth to iMonth
\r
851 getBuff from sTimeData at SYSTEMTIME.wDayOfWeek to iDayOfWeek
\r
852 getBuff from sTimeData at SYSTEMTIME.wDay to iDay
\r
853 getBuff from sTimeData at SYSTEMTIME.wHour to iHour
\r
854 getBuff from sTimeData at SYSTEMTIME.wMinute to iMinute
\r
855 getBuff from sTimeData at SYSTEMTIME.wSecond to iSecond
\r
856 getBuff from sTimeData at SYSTEMTIME.wMilliSeconds to iMilliSeconds
\r
859 append sResult iYear "," iMonth "," iDay "," iHour "," iMinute "," iSecond "," iMilliSeconds
\r
861 // give formatted date_time
\r
862 if (argv = 0) begin
\r
863 zerostring 255 to sFormattedTime
\r
864 getaddress of sFormattedTime to pFormattedTime
\r
865 move (length(sFormattedTime)) to iLenCcTime
\r
867 move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedTime, iLenCcTime)) to iDataLength
\r
869 zerostring 255 To sFormattedDate
\r
870 getaddress of sFormattedDate To pFormattedDate
\r
871 move (length(sFormattedDate)) to iLenCcDate
\r
873 move (GetDateFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedDate, iLenCcDate)) to iDataLength
\r
874 move (cstring(sFormattedDate)) to sResult
\r
875 append sResult " " (cstring(sFormattedTime)) // terminating null char removed
\r
877 function_return sResult
\r
880 // Insert zeros into the correct places to make a field x wide (similar to zeropad)
\r
881 function fill_0 global integer iValue integer iSize returns string
\r
882 local string sReturn
\r
884 move iValue to sReturn
\r
885 while (length(sReturn) < iSize)
\r
886 insert '0' in sReturn at 1
\r
889 function_return sReturn
\r
892 // Checks the runtime date format and if it's not adding on the epoch add it
\r
893 function check_date_error global string sDate returns date
\r
894 local integer iDate iY1k
\r
897 move sDate to iDate
\r
898 move 693975 to iY1k
\r
900 if (iDate < iY1k) Calc (iDate + iY1k) to iDate
\r
901 move iDate to dDate
\r
903 function_return dDate
\r
906 // Get the mod time of a file
\r
907 // This is the core of the replacement / leap year fix of GET_FILE_MOD_TIME
\r
909 // get_time(<file>, <mode>)
\r
910 // 1 = created time
\r
911 // 2 = accessed time
\r
912 // 3 = modified time
\r
914 function get_time global string sFileName integer iMode returns string
\r
915 local string sCreated sLastAccess sLastChanged sSystemTime sLocalTime sDate sTime sDateSep
\r
916 Local pointer pCreated pLastAccess pLastChanged pSystemTime pLocalTime pFileName
\r
917 Local handle hCheckFile
\r
918 Local integer iResult iVal iDateSep iDateFormat iDate4State
\r
923 getaddress of sFileName to pFileName
\r
924 move (CreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING , 0, 0)) to hCheckFile
\r
926 if (hCheckFile <> INVALID_HANDLE_VALUE) begin
\r
927 zerotype _FILETIME to sCreated
\r
928 zerotype _FILETIME to sLastAccess
\r
929 zerotype _FILETIME to sLastChanged
\r
930 zerotype _FILETIME to sLocalTime
\r
931 getAddress of sCreated to pCreated
\r
932 getAddress of sLastAccess to pLastAccess
\r
933 getAddress of sLastChanged to pLastChanged
\r
934 getAddress of sLocalTime to pLocalTime
\r
936 move (GetFileTime (hCheckFile, pCreated, pLastAccess, pLastChanged)) to iResult
\r
939 if (iMode = 1) move (FileTimeToLocalFileTime(pCreated,pLocalTime)) to iResult
\r
940 else if (iMode = 2) move (FileTimeToLocalFileTime(pLastAccess, pLocalTime)) to iResult
\r
941 else if (iMode = 3) move (FileTimeToLocalFileTime(pLastChanged, pLocalTime)) to iResult
\r
943 zerotype _SYSTEMTIME2 to sSystemTime
\r
944 getAddress of sSystemTime to pSystemTime
\r
946 move (FileTimeToSystemTime(pLocalTime, pSystemTime)) to iResult
\r
948 get_attribute DF_DATE_SEPARATOR to iDateSep
\r
949 move (character(iDateSep)) to sDateSep
\r
950 get_attribute DF_DATE_FORMAT to iDateFormat
\r
952 if (iDateFormat = DF_DATE_USA) begin
\r
953 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal
\r
954 append sDate (fill_0(iVal,2))
\r
955 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal
\r
956 append sDate sDateSep (fill_0(iVal,2))
\r
957 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal
\r
958 append sDate sDateSep (fill_0(iVal,4))
\r
960 else if iDateFormat eq DF_DATE_EUROPEAN begin
\r
961 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal
\r
962 append sDate (fill_0(iVal,2))
\r
963 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal
\r
964 append sDate sDateSep (fill_0(iVal,2))
\r
965 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal
\r
966 append sDate sDateSep (fill_0(iVal,4))
\r
968 else if iDateFormat eq DF_DATE_MILITARY begin
\r
969 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal
\r
970 append sDate (fill_0(iVal,4))
\r
971 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal
\r
972 append sDate sDateSep (fill_0(iVal,2))
\r
973 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal
\r
974 append sDate sDateSep (fill_0(iVal,2))
\r
977 getbuff from sSystemTime at SYSTEMTIME2.wHour to iVal
\r
978 append sTime (fill_0(iVal,2))
\r
979 getbuff from sSystemTime at SYSTEMTIME2.wMinute to iVal
\r
980 append sTime ":" (fill_0(iVal,2))
\r
981 getbuff from sSystemTime at SYSTEMTIME2.wSecond to iVal
\r
982 append sTime ":" (fill_0(iVal,2))
\r
986 move (CloseHandle (hCheckFile)) to iResult
\r
989 function_return sDate
\r
992 // Create a guid GUID (Microsoft)
\r
993 function create_guid global returns string
\r
994 local integer l_iThrow
\r
995 local pointer l_ptGUID l_ptGUIDString
\r
996 local string l_stGUID l_stGUIDString l_sResult
\r
998 zerotype _GUID to l_stGUID
\r
999 getaddress of l_stGUID to l_ptGUID
\r
1001 zerostring GUID_STRING_LENGTH to l_stGUIDString
\r
1002 getaddress of l_stGUIDString to l_ptGUIDString
\r
1004 if (CoCreateGuid(l_ptGUID) = 0) begin
\r
1005 // If successfully created put it in a string
\r
1006 move (StringFromGUID2(l_ptGUID, l_ptGUIDString, GUID_STRING_LENGTH)) to l_iThrow
\r
1007 move (cstring(to_ascii(l_stGUIDString))) to l_sResult
\r
1010 function_return l_sResult
\r
1013 // Get textual description of a win32 error returned by GetLastError()
\r
1014 function get_last_error_detail global integer iError returns string
\r
1015 local integer l_iThrow
\r
1016 local string l_sBuf
\r
1017 local pointer l_pBuf
\r
1019 zerostring 200 to l_sBuf
\r
1020 getaddress of l_sBuf to l_pBuf
\r
1022 move (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, iError, LANG_NEUTRAL, l_pBuf, 200, 0)) to l_iThrow
\r
1024 function_return (string(iError)+": "+l_sBuf)
\r
1027 // Get system disk info
\r
1028 // argv1 = disk mount point i.e. c:\
\r
1029 // argv2 = "" or "TOTAL", where TOTAL returns free and blank displays used.
\r
1030 function disk_info global string argv string argv2 returns number
\r
1031 local string l_sSectorsPerCluster l_sBytesPerSector l_sNumberOfFreeClusters l_sTotalNumberOfClusters
\r
1032 local pointer l_pSectorsPerCluster l_pBytesPerSector l_pNumberOfFreeClusters l_pTotalNumberOfClusters
\r
1033 local number l_iSectorsPerCluster l_iBytesPerSector l_iNumberOfFreeClusters l_iTotalNumberOfClusters l_iSpace
\r
1035 move 0 to l_iSpace
\r
1037 if (argv <> "") begin
\r
1038 zerotype _DISKDATA1 to l_sSectorsPerCluster
\r
1039 zerotype _DISKDATA2 to l_sBytesPerSector
\r
1040 zerotype _DISKDATA3 to l_sNumberOfFreeClusters
\r
1041 zerotype _DISKDATA4 to l_sTotalNumberOfClusters
\r
1043 getaddress of l_sSectorsPerCluster to l_pSectorsPerCluster
\r
1044 getaddress of l_sBytesPerSector to l_pBytesPerSector
\r
1045 getaddress of l_sNumberOfFreeClusters to l_pNumberOfFreeClusters
\r
1046 getaddress of l_sTotalNumberOfClusters to l_pTotalNumberOfClusters
\r
1048 showln (GetDiskFreeSpace(argv, l_pSectorsPerCluster, l_pBytesPerSector, l_pNumberOfFreeClusters, l_pTotalNumberOfClusters))
\r
1050 getbuff from l_sSectorsPerCluster at DISKDATA1.sectorsPerCluster to l_iSectorsPerCluster
\r
1051 getbuff from l_sBytesPerSector at DISKDATA2.bytesPerSector to l_iBytesPerSector
\r
1052 getbuff from l_sNumberOfFreeClusters at DISKDATA3.numberOfFreeClusters to l_iNumberOfFreeClusters
\r
1053 getbuff from l_sTotalNumberOfClusters at DISKDATA4.totalNumberOfClusters to l_iTotalNumberOfClusters
\r
1055 // showln l_iSectorsPerCluster
\r
1056 // showln l_iBytesPerSector
\r
1057 // showln l_iNumberOfFreeClusters
\r
1058 // showln l_iTotalNumberOfClusters
\r
1060 if (argv2 = "TOTAL") calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iTotalNumberOfClusters) to l_iSpace
\r
1061 else calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iNumberOfFreeClusters) to l_iSpace
\r
1064 function_return l_iSpace
\r
1067 // Get system memory usage
\r
1068 function get_mem_usage global returns integer
\r
1069 local integer l_iThrow l_iPid l_iMem
\r
1070 local string l_sProcessMemoryCounters
\r
1071 local pointer l_lpProcessMemoryCounters
\r
1072 local handle l_hProcess
\r
1074 zeroType _PROCESS_MEMORY_COUNTERS to l_sProcessMemoryCounters
\r
1075 getaddress of l_sProcessMemoryCounters to l_lpProcessMemoryCounters
\r
1077 put (length(l_sProcessMemoryCounters)) to l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.cb
\r
1079 move (get_process_id(0)) to l_iPid
\r
1080 move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess
\r
1082 move (GetProcessMemoryInfo(l_hProcess, l_lpProcessMemoryCounters, length(l_sProcessMemoryCounters))) to l_iThrow
\r
1083 getbuff from l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.WorkingSetSize to l_iMem
\r
1085 // showln l_hProcess " " l_iThrow
\r
1086 // showln (GetLastError())
\r
1087 // showln (get_last_error_detail(GetLastError()))
\r
1089 function_return l_iMem
\r
1092 // Uses Microsofts InternetCanonicalizeUrl functionality
\r
1093 // http:// msdn.microsoft.com/en-us/library/windows/desktop/aa384342%28v=vs.85%29.aspx
\r
1094 // https:// groups.google.com/forum/#!topic/microsoft.public.vb.winapi/0RY8jPsx_14
\r
1095 function urldecode global string argv returns string
\r
1096 local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult
\r
1097 local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength
\r
1098 local integer l_iwBufferLength l_iResult l_iDllErr
\r
1100 move argv to l_szUrl
\r
1101 move argv to l_sResult
\r
1103 if (length(l_szUrl) > 0) begin
\r
1104 zerostring ((length(l_szUrl))+1) to l_szBuffer
\r
1105 getaddress of l_szUrl to l_lpszUrl
\r
1106 getaddress of l_szBuffer to l_lpszBuffer
\r
1108 zerotype _STRUCTBYTESREAD to l_szStructBytesRead
\r
1109 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
1110 getaddress of l_szStructBytesRead to l_lpdwBufferLength
\r
1112 move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_NO_ENCODE+ICU_DECODE)) to l_iResult
\r
1114 getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength
\r
1116 if (l_iResult <> 1) begin
\r
1117 move (GetLastError()) to l_iDllErr
\r
1118 custom_error ERROR_CODE_URLDECODE$ ERROR_MSG_URLDECODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))
\r
1120 move (cstring(l_szBuffer)) to l_sResult
\r
1122 function_return l_sResult
\r
1125 // Uses Microsofts InternetCanonicalizeUrl functionality
\r
1126 // Only encodes parts before ? and #
\r
1127 function urlencode global string argv returns string
\r
1128 local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult
\r
1129 local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength
\r
1130 local integer l_iwBufferLength l_iResult l_iDllErr
\r
1132 move argv to l_szUrl
\r
1133 move argv to l_sResult
\r
1134 if (length(l_szUrl) > 0) begin
\r
1135 zerostring ((length(l_szUrl))+1) to l_szBuffer
\r
1136 getaddress of l_szUrl to l_lpszUrl
\r
1137 getaddress of l_szBuffer to l_lpszBuffer
\r
1139 zerotype _STRUCTBYTESREAD to l_szStructBytesRead
\r
1140 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
1141 getaddress of l_szStructBytesRead to l_lpdwBufferLength
\r
1143 move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_BROWSER_MODE)) to l_iResult
\r
1145 getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength
\r
1147 if (l_iResult <> 1) begin
\r
1148 move (GetLastError()) to l_iDllErr
\r
1149 custom_error ERROR_CODE_URLENCODE$ ERROR_MSG_URLENCODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))
\r
1151 move (cstring(l_szBuffer)) to l_sResult
\r
1153 function_return l_sResult
\r
1156 // Functions to pull windows os version string
\r
1157 function get_os_version global returns string
\r
1158 local string l_sOsInfo l_sVersion l_sReturn
\r
1159 local pointer l_pOsInfo
\r
1160 local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform
\r
1162 move "" to l_sVersion
\r
1164 zerotype _OSVERSIONINFO to l_sOsInfo
\r
1165 put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize
\r
1166 getaddress of l_sOsInfo to l_pOsInfo
\r
1168 move (GetVersionEx(l_pOsInfo)) to l_iResult
\r
1170 if (l_iResult = 1) begin
\r
1171 getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor
\r
1172 getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor
\r
1173 getbuff from l_sOsInfo at OSVERSIONINFO.dwBuildNumber to l_iBuild
\r
1174 getbuff from l_sOsInfo at OSVERSIONINFO.dwPlatformId to l_iPlatform
\r
1175 // getbuff from l_sOsInfo at OSVERSIONINFO.szCSDVersion to l_sVersion !??
\r
1176 move (cstring(right(l_sOsInfo,128))) to l_sVersion
\r
1179 move ("Windows Version: "+string(l_iMajor)+"."+string(l_iMinor)+" Build: "+string(l_iBuild)+" Platform: "+string(l_iPlatform)+" CSDVersion: "+l_sVersion) to l_sReturn
\r
1181 function_return l_sReturn
\r
1184 // Functions to pull windows os version as a numeric value
\r
1185 function get_os_version_numeric global returns number
\r
1186 local string l_sOsInfo l_sVersion
\r
1187 local pointer l_pOsInfo
\r
1188 local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform
\r
1190 move "" to l_sVersion
\r
1192 zerotype _OSVERSIONINFO to l_sOsInfo
\r
1193 put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize
\r
1194 getaddress of l_sOsInfo to l_pOsInfo
\r
1196 move (GetVersionEx(l_pOsInfo)) to l_iResult
\r
1198 if (l_iResult = 1) begin
\r
1199 getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor
\r
1200 getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor
\r
1203 function_return (number(l_iMajor)+(number(l_iMinor)/10))
\r
1206 // Converts binary to hex or base64 strings and vice versa
\r
1207 function binary_to_string_to_binary global string argv string argv2 string argv3 returns string
\r
1208 local string l_sData l_sDataDecoded l_sDataSizeDecoded l_sReturn
\r
1209 local pointer l_pData l_pDataDecoded l_pDataSizeDecoded
\r
1210 local integer l_iResult l_iDataSize l_iDataSizeDecoded l_iOffset
\r
1212 move argv to l_sData
\r
1213 move (length(l_sData)) to l_iDataSize
\r
1214 getaddress of l_sData to l_pData
\r
1216 zerostring ((length(l_sData)*4)+1) to l_sDataDecoded
\r
1217 getaddress of l_sDataDecoded to l_pDataDecoded
\r
1219 zerotype _DW_TYPE to l_sDataSizeDecoded
\r
1220 put (length(l_sDataDecoded)) to l_sDataSizeDecoded at DW_TYPE.value
\r
1221 getaddress of l_sDataSizeDecoded to l_pDataSizeDecoded
\r
1224 case (argv2 = "HEX") begin
\r
1225 if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult
\r
1226 if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult
\r
1229 case (argv2 = "BASE64") begin
\r
1230 if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult
\r
1231 if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult
\r
1234 case else custom_error ERROR_CODE_UNKNOWN_FORMAT$ ERROR_MSG_UNKNOWN_FORMAT argv2
\r
1237 getbuff from l_sDataSizeDecoded at DW_TYPE.value to l_iDataSizeDecoded
\r
1239 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1240 showln "ERROR: " (ternary(argv3 = 0, "CryptBinaryToString", "CryptStringToBinary")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1241 showln "DATA = " l_sDataDecoded
\r
1242 showln "SIZE = " l_iDataSizeDecoded
\r
1245 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
1246 else move (cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset))) to l_sReturn
\r
1249 function_return l_sReturn
\r
1252 // Convert binary data to hex or base64
\r
1253 function binary_to_string global string argv string argv2 returns string
\r
1254 function_return (binary_to_string_to_binary(argv, argv2, 0))
\r
1256 // Convert hex or base64 strings to binary data
\r
1257 function string_to_binary global string argv string argv2 returns string
\r
1258 function_return (binary_to_string_to_binary(argv, argv2, 1))
\r
1261 // List out cryptographic providers on ms windows
\r
1262 function ms_adv_listproviders global returns integer
\r
1263 local integer l_i l_iResult l_iType
\r
1264 local string l_sType l_sName l_sNameSize
\r
1265 local pointer l_pType l_pName l_pNameSize
\r
1271 zerotype _DW_TYPE to l_sType
\r
1272 getaddress of l_sType to l_pType
\r
1274 zerostring 255 to l_sName
\r
1275 getaddress of l_sName to l_pName
\r
1277 zerotype _DW_TYPE to l_sNameSize
\r
1278 put length(l_sName) to l_sNameSize at DW_TYPE.value
\r
1279 getaddress of l_sNameSize to l_pNameSize
\r
1281 move (CryptEnumProviders(l_i, HEXNULL, 0, l_pType, l_pName, l_pNameSize)) to l_iResult
\r
1283 if ((l_iResult <> 1) and (GetLastError() <> 0) and (GetLastError() <> 259)) begin
\r
1284 showln "ERROR: " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1286 getbuff from l_sType at DW_TYPE.value to l_iType
\r
1288 if (l_iResult = 1) showln l_i ") " l_iType " - '" (cstring(l_sName)) "'"
\r
1289 until (l_iResult <> 1)
\r
1293 //-------------------------------------------------------------------------
\r
1295 //-------------------------------------------------------------------------
\r
1297 // Object to provide basic implimentations of some popular hash algorithms and encryption
\r
1298 // provided by the Microsoft Cryptographic Provider
\r
1300 // Send message methods:
\r
1302 // aquire_context - Create the context of the Microsoft CSP
\r
1303 // release_context - Release the context of the Microsoft CSP
\r
1304 // import_key <key> <ealg> - Incomplete/WIP
\r
1305 // derive_key <psw> <halg> <ealg>- Derives an encryption key provider when supplied
\r
1306 // with a password, a hash algorithm and the required
\r
1308 // modify_key_iv <iv> - Set the initilization vector of the key provider
\r
1309 // modify_key_mode <mode> - Set the key provider mode E.g. CBC, ECB etc
\r
1310 // destroy_key - Dispose of the current key provider
\r
1313 // hash_data <data> <halg> - Returns a hash of the passed data in the specified
\r
1315 // export_key - Returns the current encryption key
\r
1316 // generate_random_key_iv - Generates and sets a random initilization vector
\r
1317 // for the key provider
\r
1318 // encrypt <data> - Encrypt data
\r
1319 // decrypt <data> - Decrypt data
\r
1323 // object test is an msAdvCrypt
\r
1325 // string data buf
\r
1327 // // Generate a hash
\r
1328 // send aquire_context to test
\r
1329 // get hash_data of test "MYTEXT" "SHA1" to data
\r
1330 // send release_context to test
\r
1331 // showln "HASHED: " (binary_to_string(data,"HEX"))
\r
1333 // // Encrypt some data
\r
1334 // send aquire_context to test
\r
1335 // send derive_key to test "MYPASSWORD" "SHA256" "AES_256"
\r
1336 // send modify_key_mode to test "CBC"
\r
1337 // get generate_random_key_iv of test to buf
\r
1338 // move buf to data
\r
1339 // get encrypt of test "MYDATA" to buf
\r
1340 // append data buf
\r
1341 // send destroy_key to test
\r
1342 // send release_context to test
\r
1343 // showln "ENCRYPTED: " (binary_to_string(data,"HEX"))
\r
1345 // // Decrypt some data
\r
1346 // send aquire_context to test
\r
1347 // send derive_key to test "MYPASSWORD" "SHA256" "AES_256"
\r
1348 // send modify_key_mode to test "CBC"
\r
1349 // send modify_key_iv to test (mid(data,16,1))
\r
1350 // get decrypt of test (mid(data,length(data)-16,17)) to data
\r
1351 // send destroy_key to test
\r
1352 // send release_context to test
\r
1353 // showln "DECRYPTED: " data
\r
1355 class msAdvCrypt is an array
\r
1356 procedure construct_object string argc
\r
1357 forward send construct_object argc
\r
1359 property handle c_hProv
\r
1360 property handle c_hHash
\r
1361 property handle c_hKey
\r
1362 property string c_sAlg
\r
1365 procedure aquire_context
\r
1366 local integer l_iResult
\r
1367 local handle l_hProv
\r
1368 local string l_shProv
\r
1369 local pointer l_phProv
\r
1371 zerotype _DW_TYPE to l_shProv
\r
1372 getaddress of l_shProv to l_phProv
\r
1374 if (get_os_version_numeric() < 5.2) begin
\r
1375 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult
\r
1376 if (GetLastError() = -2146893802) begin
\r
1377 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult
\r
1381 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult
\r
1382 if (GetLastError() = -2146893802) begin
\r
1383 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult
\r
1387 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1388 showln "ERROR: CryptAcquireContext " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1391 getbuff from l_shProv at DW_TYPE.value to l_hProv
\r
1392 set c_hProv to l_hProv
\r
1396 function make_hash string in_data string in_hashalgorithm returns string
\r
1397 local integer l_iResult l_iHashSize
\r
1398 local string l_shHash l_sHash l_sRawString l_sHashSize
\r
1399 local handle l_hProv l_hHash
\r
1400 local pointer l_phHash l_pHash l_pRawString l_pHashSize
\r
1402 get c_hProv to l_hProv
\r
1404 if (l_hProv = 0) begin
\r
1405 custom_error ERROR_CODE_NO_CONTEXT$ ERROR_MSG_NO_CONTEXT
\r
1408 move in_data to l_sRawString
\r
1409 getaddress of l_sRawString to l_pRawString
\r
1411 zerotype _HCRYPTHASH to l_shHash
\r
1412 getaddress of l_shHash to l_phHash
\r
1415 case (in_hashalgorithm = "MD5") begin
\r
1416 move (CryptCreateHash(l_hProv, CALG_MD5, 0, 0, l_phHash)) to l_iResult
\r
1417 zerostring (128/8) to l_sHash
\r
1420 case ((in_hashalgorithm = "SHA1") or (in_HASHalgorithm = "SHA")) begin
\r
1421 move (CryptCreateHash(l_hProv, CALG_SHA1, 0, 0, l_phHash)) to l_iResult
\r
1422 zerostring (160/8) to l_sHash
\r
1425 case (in_hashalgorithm = "SHA256") begin
\r
1426 move (CryptCreateHash(l_hProv, CALG_SHA_256, 0, 0, l_phHash)) to l_iResult
\r
1427 zerostring (256/8) to l_sHash
\r
1430 case (in_hashalgorithm = "SHA384") begin
\r
1431 move (CryptCreateHash(l_hProv, CALG_SHA_384, 0, 0, l_phHash)) to l_iResult
\r
1432 zerostring (384/8) to l_sHash
\r
1435 case (in_hashalgorithm = "SHA512") begin
\r
1436 move (CryptCreateHash(l_hProv, CALG_SHA_512, 0, 0, l_phHash)) to l_iResult
\r
1437 zerostring (512/8) to l_sHash
\r
1441 custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_hashalgorithm
\r
1445 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1446 showln "ERROR: CryptCreateHash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1449 getbuff from l_shHash at HCRYPTHASH.value to l_hHash
\r
1450 getaddress of l_sHash to l_pHash
\r
1452 move (CryptHashData(l_hHash, l_pRawString, (length(l_sRawString)), 0)) to l_iResult
\r
1454 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1455 showln "ERROR: Crypthash_data " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1458 zerotype _DW_TYPE to l_sHashSize
\r
1459 put (length(l_sHash)) to l_sHashSize at DW_TYPE.value
\r
1460 getaddress of l_sHashSize to l_pHashSize
\r
1462 move (CryptGetHashParam(l_hHash, HP_HASHVAL, l_pHash, l_pHashSize, 0)) to l_iResult
\r
1464 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1465 showln "ERROR: CryptGetHashParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1468 getbuff from l_sHashSize at DW_TYPE.value to l_iHashSize
\r
1470 if (l_iHashSize <> length(l_sHash)) begin
\r
1471 showln "WARNING: Binary data does not match expected hash size:"
\r
1472 showln "DATA = " l_sHash
\r
1473 showln "SIZE = " l_iHashSize " / " (length(l_sHash))
\r
1477 set c_hHash to l_hHash
\r
1479 function_return (mid(l_sHash,l_iHashSize,1))
\r
1482 procedure destroy_hash
\r
1483 local integer l_iResult
\r
1484 local handle l_hHash
\r
1486 get c_hHash to l_hHash
\r
1488 if (l_hHash <> 0) begin
\r
1489 move (CryptDestroyHash(l_hHash)) to l_iResult
\r
1490 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1491 showln "ERROR: Cryptdestroy_hash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1493 else set c_hHash to 0
\r
1497 function hash_data string in_data string in_hashalgorithm returns string
\r
1498 local integer l_iResult
\r
1499 local string l_sHash
\r
1501 get make_hash in_data in_hashalgorithm to l_sHash
\r
1504 function_return (cstring(l_sHash))
\r
1508 procedure import_key string in_key string in_algorithm
\r
1509 local integer l_iResult
\r
1510 local string l_sBlobHeader l_sPlainTextKeyBlob l_shKey
\r
1511 local handle l_hProv l_hKey
\r
1512 local pointer l_pPlainTextKeyBlob l_phKey
\r
1514 get c_hProv to l_hProv
\r
1516 zerotype _BLOBHEADER to l_sBlobHeader
\r
1517 put PLAINTEXTKEYBLOB to l_sBlobHeader at BLOBHEADER.bType
\r
1518 put 2 to l_sBlobHeader at BLOBHEADER.bVersion
\r
1519 put 0 to l_sBlobHeader at BLOBHEADER.Reserved
\r
1522 case (in_algorithm = "DES") put CALG_DES to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1524 case (in_algorithm = "3DES") put CALG_3DES to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1526 case (in_algorithm = "3DES_112") put CALG_3DES_112 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1528 case (in_algorithm = "AES") put CALG_AES to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1530 case (in_algorithm = "AES_128") put CALG_AES_128 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1532 case (in_algorithm = "AES_192") put CALG_AES_192 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1534 case (in_algorithm = "AES_256") put CALG_AES_256 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1536 case (in_algorithm = "RC2") put CALG_RC2 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1538 case (in_algorithm = "RC4") put CALG_RC4 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1540 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm
\r
1543 zerotype _PLAINTEXTKEYBLOB to l_sPlainTextKeyBlob
\r
1544 put l_sBlobHeader to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.BLOBHEADER
\r
1545 put (length(in_key)) to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.dwKeySize
\r
1546 put_string in_key to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.rgbKeyData
\r
1548 getaddress of l_sPlainTextKeyBlob to l_pPlainTextKeyBlob
\r
1550 zerotype _HCRYPTKEY to l_shKey
\r
1551 getaddress of l_shKey to l_phKey
\r
1553 move (CryptImportKey(l_hProv, l_pPlainTextKeyBlob, length(l_sPlainTextKeyBlob), 0, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1555 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1556 showln "ERROR: CryptImportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1559 getbuff from l_shKey at HCRYPTKEY.value to l_hKey
\r
1563 procedure derive_key string in_data string in_hashalgorithm string in_algorithm
\r
1564 local integer l_iResult
\r
1565 local handle l_hProv l_hHash l_hKey
\r
1566 local string l_sKey l_shKey
\r
1567 local pointer l_phKey
\r
1569 get c_hProv to l_hProv
\r
1570 get make_hash in_data in_hashalgorithm to l_sKey
\r
1571 get c_hHash to l_hHash
\r
1573 if (l_hHash <> 0) begin
\r
1574 zerotype _HCRYPTKEY to l_shKey
\r
1575 getaddress of l_shKey to l_phKey
\r
1577 // 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
1579 case (in_algorithm = "DES") move (CryptDeriveKey(l_hProv, CALG_DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1581 case (in_algorithm = "3DES") move (CryptDeriveKey(l_hProv, CALG_3DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1583 case (in_algorithm = "3DES_112") move (CryptDeriveKey(l_hProv, CALG_3DES_112, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1585 case (in_algorithm = "AES") move (CryptDeriveKey(l_hProv, CALG_AES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1587 case (in_algorithm = "AES_128") move (CryptDeriveKey(l_hProv, CALG_AES_128, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1589 case (in_algorithm = "AES_192") move (CryptDeriveKey(l_hProv, CALG_AES_192, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1591 case (in_algorithm = "AES_256") move (CryptDeriveKey(l_hProv, CALG_AES_256, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1593 case (in_algorithm = "RC2") move (CryptDeriveKey(l_hProv, CALG_RC2, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1595 case (in_algorithm = "RC4") move (CryptDeriveKey(l_hProv, CALG_RC4, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1597 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm
\r
1600 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1601 showln "ERROR: CryptDeriveKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1604 getbuff from l_shKey at HCRYPTKEY.value to l_hKey
\r
1605 set c_sAlg to in_algorithm
\r
1608 set c_hKey to l_hKey
\r
1612 procedure modify_key_iv string in_iv
\r
1613 local integer l_iResult l_iBlockSize
\r
1614 local handle l_hKey
\r
1615 local string l_sIV l_sAlg
\r
1616 local pointer l_pIV
\r
1618 get c_hKey to l_hKey
\r
1619 get c_sAlg to l_sAlg
\r
1621 // Set expected block size in bytes
\r
1623 case (l_sAlg contains "DES") calc (64/8) to l_iBlockSize
\r
1625 case (l_sAlg contains "AES") calc (128/8) to l_iBlockSize
\r
1627 case (l_sAlg = "RC2") calc (64/8) to l_iBlockSize
\r
1629 case else custom_error ERROR_CODE_INCOMPATIBLE_ALGORITHM$ ERROR_MSG_INCOMPATIBLE_ALGORITHM l_sAlg
\r
1632 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
1634 move in_iv to l_sIV
\r
1635 getaddress of l_sIV to l_pIV
\r
1637 move (CryptSetKeyParam(l_hKey, KP_IV, l_pIV, 0)) to l_iResult
\r
1639 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1640 showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1645 function generate_random_key_iv returns string
\r
1646 local integer l_i l_iBlockSize
\r
1647 local string l_sIV l_sAlg
\r
1649 get c_sAlg to l_sAlg
\r
1652 if ((l_sAlg contains "DES") or (l_sAlg = "RC2")) calc (64/8) to l_iBlockSize
\r
1653 if (l_sAlg contains "AES") calc (128/8) to l_iBlockSize
\r
1655 for l_i from 1 to l_iBlockSize
\r
1656 append l_sIV (character(48+random(47)))
\r
1659 send modify_key_iv l_sIV
\r
1661 function_return l_sIV
\r
1664 procedure modify_key_mode string in_mode
\r
1665 local integer l_iResult
\r
1666 local handle l_hKey
\r
1667 local string l_sMode l_sbData
\r
1668 local pointer l_pbData
\r
1670 get c_hKey to l_hKey
\r
1673 case (in_mode contains "CBC") move CRYPT_MODE_CBC to l_sMode
\r
1675 case (in_mode contains "ECB") move CRYPT_MODE_ECB to l_sMode
\r
1677 case (in_mode contains "OFB") move CRYPT_MODE_OFB to l_sMode
\r
1679 case (in_mode contains "CFB") move CRYPT_MODE_CFB to l_sMode
\r
1681 case (in_mode contains "CTS") move CRYPT_MODE_CTS to l_sMode
\r
1683 case else custom_error ERROR_CODE_UNRECOGNISED_MODE$ ERROR_MSG_UNRECOGNISED_MODE l_sMode
\r
1686 zerotype _DW_TYPE to l_sbData
\r
1687 put l_sMode to l_sbData at DW_TYPE.value
\r
1688 getaddress of l_sbData to l_pbData
\r
1690 move (CryptSetKeyParam(l_hKey, KP_MODE, l_pbData, 0)) to l_iResult
\r
1692 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1693 showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1698 function export_key returns string
\r
1699 local integer l_iResult
\r
1700 local string l_sData l_sDataSize
\r
1701 local handle l_hKey
\r
1702 local pointer l_pData l_pDataSize
\r
1703 local integer l_iKeyBlobSize l_iDataSize
\r
1705 get c_hKey to l_hKey
\r
1707 if (l_hKey <> 0) begin
\r
1708 zerotype _PLAINTEXTKEYBLOB to l_sData
\r
1709 getaddress of l_sData to l_pData
\r
1711 zerotype _DW_TYPE to l_sDataSize
\r
1712 put (length(l_sData)) to l_sDataSize at DW_TYPE.value
\r
1713 getaddress of l_sDataSize to l_pDataSize
\r
1715 move (CryptExportKey(l_hKey, 0, PLAINTEXTKEYBLOB, 0, l_pData, l_pDataSize)) to l_iResult
\r
1716 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1717 showln "ERROR: CryptExportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1720 getbuff from l_sDataSize at DW_TYPE.value to l_iKeyBlobSize
\r
1721 getbuff from l_sData at PLAINTEXTKEYBLOB.dwKeySize to l_iDataSize
\r
1722 move (mid(l_sData,l_iDataSize,13)) to l_sData
\r
1724 if (show_debug_lines) begin
\r
1725 showln "DEBUG: Key blob Size = " l_iKeyBlobSize
\r
1728 function_return l_sData
\r
1731 function encrypt_decrypt string in_data integer in_decrypt returns string
\r
1732 local integer l_iResult l_iDataSize
\r
1733 local string l_sData l_sDataSize
\r
1734 local pointer l_pData l_pDataSize
\r
1735 local handle l_hKey
\r
1737 move in_data to l_sData
\r
1738 get c_hKey to l_hKey
\r
1740 zerotype _DW_TYPE to l_sDataSize
\r
1741 put (length(l_sData)) to l_sDataSize at DW_TYPE.value
\r
1742 getaddress of l_sDataSize to l_pDataSize
\r
1744 move (l_sData+repeat(' ',length(l_sData)*2)) to l_sData
\r
1745 getaddress of l_sData to l_pData
\r
1747 if (in_decrypt = 0) move (CryptEncrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize, length(l_sData))) to l_iResult
\r
1748 else move (CryptDecrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize)) to l_iResult
\r
1750 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1751 showln "ERROR: " (ternary(in_decrypt = 0, "CryptEncrypt", "CryptDecrypt")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1754 getbuff from l_sDataSize at DW_TYPE.value to l_iDataSize
\r
1755 move (cstring(mid(l_sData,l_iDataSize,1))) to l_sData
\r
1757 function_return l_sData
\r
1760 function encrypt string in_data returns string
\r
1761 local string l_sData
\r
1763 get encrypt_decrypt in_data 0 to l_sData
\r
1764 function_return l_sData
\r
1767 function decrypt string in_data returns string
\r
1768 local string l_sData
\r
1770 get encrypt_decrypt in_data 1 to l_sData
\r
1771 function_return l_sData
\r
1774 procedure destroy_key
\r
1775 local integer l_iResult
\r
1776 local handle l_hKey l_hHash
\r
1778 get c_hKey to l_hKey
\r
1780 if (l_hKey <> 0) begin
\r
1781 move (CryptDestroyKey(l_hKey)) to l_iResult
\r
1782 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1783 showln "ERROR: CryptDestroyKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1791 get c_hHash to l_hHash
\r
1792 if (l_hHash <> 0) send destroy_hash
\r
1796 procedure release_context
\r
1797 local integer l_iResult
\r
1798 local handle l_hProv
\r
1800 get c_hProv to l_hProv
\r
1802 if (l_hProv <> 0) begin
\r
1803 move (CryptReleaseContext(l_hProv, 0)) to l_iResult
\r
1804 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1805 showln "ERROR: Cryptrelease_context " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1807 else set c_hProv to 0
\r
1812 procedure destory_object
\r
1813 local handle l_hProv l_hHash l_hKey
\r
1815 get c_hKey to l_hKey
\r
1816 if (l_hKey <> 0) send destroy_key
\r
1818 get c_hHash to l_hHash
\r
1819 if (l_hHash <> 0) send destroy_hash
\r
1821 get c_hProv to l_hProv
\r
1822 if (l_hProv <> 0) send release_context
\r
1824 forward send destory_object
\r
1829 //-------------------------------------------------------------------------
\r
1831 //-------------------------------------------------------------------------
\r
1833 // Used for procedural invocations of hashing and encrypting
\r
1834 object msAdvCrypt_global_obj is an msAdvCrypt
\r
1837 // Procedural one-shot use of msAdvCrypt hashing
\r
1838 function msAdvCrypt_hash global string in_data string in_hash returns string
\r
1839 local string l_sReturn
\r
1841 send aquire_context to msAdvCrypt_global_obj
\r
1842 get make_hash of msAdvCrypt_global_obj in_data in_hash to l_sReturn
\r
1843 send destroy_hash to msAdvCrypt_global_obj
\r
1844 send release_context to msAdvCrypt_global_obj
\r
1846 function_return l_sReturn
\r
1849 function sha512_hex global string in_data returns string
\r
1850 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'HEX'))
\r
1853 function sha512_base64 global string in_data returns string
\r
1854 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'BASE64'))
\r
1857 function sha384_hex global string in_data returns string
\r
1858 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'HEX'))
\r
1861 function sha384_base64 global string in_data returns string
\r
1862 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'BASE64'))
\r
1865 function sha256_hex global string in_data returns string
\r
1866 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'HEX'))
\r
1869 function sha256_base64 global string in_data returns string
\r
1870 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'BASE64'))
\r
1873 function sha1_hex global string in_data returns string
\r
1874 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'HEX'))
\r
1877 function sha1_base64 global string in_data returns string
\r
1878 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'BASE64'))
\r
1881 function md5_hex global string in_data returns string
\r
1882 function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'HEX'))
\r
1885 function md5_base64 global string in_data returns string
\r
1886 function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'BASE64'))
\r
1889 // Procedural one-shot use of msAdvCrypt AES256 encryption (HEX)
\r
1890 function aes256_hex_enc global string in_data string in_key returns string
\r
1891 local string l_sReturn l_sBuf
\r
1893 send aquire_context to msAdvCrypt_global_obj
\r
1895 send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"
\r
1896 send modify_key_mode to msAdvCrypt_global_obj "CBC"
\r
1898 get generate_random_key_iv of msAdvCrypt_global_obj to l_sBuf
\r
1899 move l_sBuf to l_sReturn
\r
1901 get encrypt of msAdvCrypt_global_obj in_data to l_sBuf
\r
1902 append l_sReturn l_sBuf
\r
1904 send destroy_key to msAdvCrypt_global_obj
\r
1905 send release_context to msAdvCrypt_global_obj
\r
1907 function_return (binary_to_string(l_sReturn,"HEX"))
\r
1910 // Procedural one-shot use of msAdvCrypt AES256 decryption (HEX)
\r
1911 function aes256_hex_dec global string in_data string in_key returns string
\r
1912 local string l_sReturn l_sBuf
\r
1914 move (string_to_binary(in_data,"HEX")) to l_sBuf
\r
1916 send aquire_context to msAdvCrypt_global_obj
\r
1917 send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"
\r
1918 send modify_key_mode to msAdvCrypt_global_obj "CBC"
\r
1920 send modify_key_iv to msAdvCrypt_global_obj (mid(l_sBuf,16,1))
\r
1922 get decrypt of msAdvCrypt_global_obj (mid(l_sBuf,length(l_sBuf)-16,17)) to l_sReturn
\r
1924 send destroy_key to msAdvCrypt_global_obj
\r
1925 send release_context to msAdvCrypt_global_obj
\r
1927 function_return l_sReturn
\r