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 // Manipulate cmd window to minimise maximise etc. E.g show_window("pap", SW_MINIMIZE)
457 function show_window global string argv integer argv2 returns integer
461 move (SetConsoleTitle(argv)) to strmark
462 move (FindWindow(0, argv)) to hWnd
463 move (ShowWindow(hWnd, argv2)) to ret
468 // This function will run any external application directly from dataflex
\r
469 // argv = application to run (command name/path) argv2 = any parameters to pass to the program argv3 = directory to run from
\r
470 function shell_exec global string argv string argv2 string argv3 returns integer
\r
471 local handle windowHandle
\r
472 local pointer lpOperation lpFile lpParameters lpDirectory
\r
473 local integer nShowCmd l_iResult
\r
474 local string sOperation sFile sParameters sDirectory
\r
476 if ((trim(argv)) <> "") begin
\r
477 move 0 to windowHandle
\r
478 move "open" to sOperation
\r
480 if ((trim(argv2)) <> "") move argv2 to sParameters
\r
481 else move "" to sParameters
\r
482 if ((trim(argv3)) <> "") move argv3 to sDirectory
\r
483 else move "" to sDirectory
\r
484 move "" to sDirectory
\r
486 getAddress of sOperation to lpOperation
\r
487 getAddress of sFile to lpFile
\r
488 getAddress of sParameters to lpParameters
\r
489 getAddress of sDirectory to lpDirectory
\r
491 move (ShellExecute(windowHandle,lpOperation,lpFile,lpParameters,lpDirectory,SW_SHOWMAXIMIZED)) to l_iResult
\r
495 // This function will run the console application stated in argv1
\r
496 // argv2 = set to 1 to run the process in a new window
\r
497 // argv3 = set to 1 to leave the new process running and continue without killing it
\r
498 // argv4 = The time to live before killing the process - set to zero to wait until finished
\r
499 // Note - Setting argv3 to 1 will result in build up of open handles for finished processes
\r
500 // if term_proc is not used to terminate the process.
\r
501 // It is possible to have multiple processes running in one window by
\r
502 // setting argv2 = 0 and argv3 = 1, but handling how they behave on the screen
\r
503 // requires some careful fiddling.
\r
504 function create_proc global string argv integer argv2 integer argv3 integer argv4 returns string
\r
505 local pointer lpProcessInformation lpStartupInformation
\r
506 local integer l_iResult
\r
507 local pointer lpApplicationName lpCommandLine lpProcessAttributes lpThreadAttributes lpEnvironment lpCurrentDirectory
\r
508 local integer bInheritHandles iProcessAttributes iThreadAttributes iEnvironment
\r
509 local dword dwCreationFlags dwMilliseconds
\r
510 local string sProcessInformation sStartupInformation sApplicationName sCommandLine sCurrentDirectory l_sExit l_sTmp
\r
511 local handle hProcess hThread
\r
513 zeroType _PROCESS_INFORMATION to sProcessInformation
\r
514 zeroType _STARTUPINFO to sStartupInformation
\r
516 move STRINGNULL to l_sExit
\r
517 move STRINGNULL to sApplicationName
\r
518 move argv to sCommandLine
\r
519 move HEXNULL to iProcessAttributes
\r
520 move HEXNULL to iThreadAttributes
\r
521 move HEXTRUE to bInheritHandles
\r
522 move HEXNULL to iEnvironment
\r
523 move STRINGNULL to sCurrentDirectory
\r
524 if (argv2 = 0) move NORMAL_PRIORITY_CLASS to dwCreationFlags
\r
525 if (argv2 = 1) move (CREATE_NEW_CONSOLE+NORMAL_PRIORITY_CLASS) to dwCreationFlags
\r
527 getaddress of sApplicationName to lpApplicationName
\r
528 getaddress of sCommandLine to lpCommandLine
\r
529 getaddress of iProcessAttributes to lpProcessAttributes
\r
530 getaddress of iThreadAttributes to lpThreadAttributes
\r
531 getaddress of iEnvironment to lpEnvironment
\r
532 getaddress of sCurrentDirectory to lpCurrentDirectory
\r
533 getaddress of sProcessInformation to lpProcessInformation
\r
534 getaddress of sStartupInformation to lpStartupInformation
\r
536 put (length(sStartupInformation)) to sStartupInformation at STARTUPINFO.cb
\r
538 move (CreateProcess(lpApplicationName,lpCommandLine,lpProcessAttributes,lpThreadAttributes,dwCreationFlags,dwCreationFlags,lpEnvironment,lpCurrentDirectory,lpStartupInformation,lpProcessInformation)) to l_iResult
\r
540 getbuff from sProcessInformation at PROCESS_INFORMATION.hProcess to hProcess
\r
541 getbuff from sProcessInformation at PROCESS_INFORMATION.hThread to hThread
\r
543 if (argv3 <> 1) begin
\r
544 if (argv4 = 0) move INFINITE to dwMilliseconds
\r
545 if (argv4 <> 0) move argv4 to dwMilliseconds
\r
546 move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult
\r
547 move (TerminateProcess(hProcess,HEXNULL)) to l_iResult
\r
548 move (CloseHandle(hThread)) to l_iResult
\r
549 move (CloseHandle(hProcess)) to l_iResult
\r
551 if (argv3 = 1) begin
\r
552 move hProcess to l_sExit
\r
553 append l_sExit "|" hThread
\r
556 function_return l_sExit
\r
559 // This will terminate a process started in create_proc with argv3 set to 1
\r
560 // move the string returned by create_proc to argv
\r
561 // set argv2 to 0 if you want to wait for the process to finish before terminating
\r
562 // set argv2 to 1 if you want to terminate the process without waiting for it to finish
\r
563 function term_proc global string argv integer argv2 returns integer
\r
564 local integer l_iSuccess
\r
565 local integer dwMilliseconds l_iResult
\r
566 local handle hProcess hThread
\r
568 move 0 to l_iSuccess
\r
569 move (trim(argv)) to argv
\r
570 if ((argv contains "|") and ((length(argv)) >= 3)) begin
\r
571 move (left(argv,(pos("|",argv)-1))) to hProcess
\r
572 move (mid(argv,(length(argv)-pos("|",argv)),(pos("|",argv)+1))) to hThread
\r
573 move INFINITE to dwMilliseconds
\r
574 if (argv2 = 0) move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult
\r
575 move (TerminateProcess(hProcess,HEXNULL)) to l_iResult
\r
576 move (CloseHandle(hThread)) to l_iResult
\r
577 move (CloseHandle(hProcess)) to l_iResult
\r
580 function_return l_iSuccess
\r
583 // Check if a file is locked by a windows process
\r
584 // Returns 1 if the file is locked.
\r
585 function is_locked global string argv returns integer
\r
586 local integer l_iResult l_iDllErr l_iThrow
\r
587 local handle l_hFile
\r
588 move 0 to l_iResult
\r
590 move (trim(argv)) to argv
\r
591 if (argv <> "") begin
\r
592 move (lOpen(argv,(OF_READ+OF_SHARE_EXCLUSIVE))) to l_hFile
\r
593 move (GetLastError()) to l_iDllErr
\r
594 if ((l_hFile = -1) and (l_iDllErr = 32)) move 1 to l_iResult
\r
595 if (l_hFile <> -1) begin
\r
596 move (lClose(l_hFile)) to l_iThrow
\r
599 function_return l_iResult
\r
602 // Check if a file exists. Returns 1 if the file exists.
\r
603 function does_exist global string argv returns integer
\r
604 local integer l_iResult l_iDllErr l_iThrow
\r
605 local handle l_hFile
\r
606 move 0 to l_iResult
\r
608 move (trim(argv)) to argv
\r
609 if (argv <> "") begin
\r
610 move 1 to l_iResult
\r
611 move (lOpen(argv,(OF_READ+OF_SHARE_DENY_NONE))) to l_hFile
\r
612 move (GetLastError()) to l_iDllErr
\r
613 if ((l_hFile = -1) and (l_iDllErr = 2)) move 0 to l_iResult
\r
614 if (l_hFile <> -1) begin
\r
615 move (lClose(l_hFile)) to l_iThrow
\r
618 function_return l_iResult
\r
621 // Read a text file line by line into the buffer array "Win32API_buffer"
\r
622 // Returns an integer i-1 where i is the count of array elements/lines.
\r
624 // Ref: http:// msdn2.microsoft.com/en-us/library/aa365467.aspx
\r
625 function buffer_text_file global string argv string argv2 returns integer
\r
626 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
627 local handle l_hFileHandle l_hFile
\r
628 local pointer l_pFileName l_pBuf l_pBytesRead
\r
629 local integer l_iFileSize l_iThrow l_iBytesRead l_iBytesToRead l_i l_iDllErr l_iLines
\r
631 send delete_data to Win32API_buffer
\r
632 move -1 to l_iLines
\r
634 move (trim(argv)) to argv
\r
635 move (trim(argv2)) to argv2
\r
636 move -1 to l_hFileHandle
\r
637 move 0 to l_iBytesRead
\r
638 move 1 to l_iBytesToRead
\r
641 if (argv <> "") begin
\r
642 getaddress of argv to l_pFileName
\r
643 move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile
\r
644 move (GetFileSize(l_hFile,0)) to l_iFileSize
\r
645 for l_i from 1 to l_iFileSize
\r
646 // move (SetFilePointer(l_hFile,l_i,0,FILE_CURRENT)) to l_iThrow
\r
647 zerostring 1 to l_sBuf
\r
648 getaddress of l_sBuf to l_pBuf
\r
649 zerotype _STRUCTBYTESREAD to l_structBytesRead
\r
650 getaddress of l_structBytesRead to l_pBytesRead
\r
651 move (ReadFile(l_hFile,l_pBuf,l_iBytesToRead,l_pBytesRead,HexNull)) to l_iThrow
\r
652 getbuff from l_structBytesRead at STRUCTBYTESREAD.integer0 to l_iBytesRead
\r
653 if ((ascii(l_sBuf) = 10) or (ascii(l_sBuf) = 13) or ((argv2 <> "") and (argv2 = l_sBuf))) begin
\r
654 if (ascii(l_sBufL) <> 13) begin
\r
656 set array_value of (Win32API_buffer(current_object)) item l_iLines to l_sLine
\r
661 if ((ascii(l_sBuf) <> 10) and (ascii(l_sBuf) <> 13) and ((argv2 = "") or (argv2 <> l_sBuf))) append l_sLine l_sBuf
\r
662 move l_sBuf to l_sBufL
\r
664 move (CloseHandle(l_hFile)) to l_iThrow
\r
666 function_return l_iLines
\r
669 // Return file size in bytes from win32
\r
670 function file_size_bytes global string argv returns integer
\r
671 local integer l_iFileSize l_iThrow
\r
672 local pointer l_pFileName
\r
673 local handle l_hFile
\r
675 move -1 to l_iFileSize
\r
677 if (argv <> "") begin
\r
678 getaddress of argv to l_pFileName
\r
679 move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile
\r
680 move (GetFileSize(l_hFile,0)) to l_iFileSize
\r
681 move (CloseHandle(l_hFile)) to l_iThrow
\r
684 function_return l_iFileSize
\r
687 // Attempt to convert a string from unicode to ASCII/cp850 via WideCharToMultiByte
\r
688 // http:// msdn2.microsoft.com/en-us/library/ms776420.aspx
\r
689 function to_ascii global string argv returns string
\r
690 local string l_sAscii l_sUnicode
\r
691 local pointer l_pAscii l_pUnicode
\r
692 local integer l_iCharsNeeded l_iThrow
\r
693 move (trim(argv)) to l_sUnicode
\r
695 if (l_sUnicode <> "") begin
\r
696 zerostring (length(l_sUnicode)) to l_sAscii
\r
697 getAddress of l_sAscii to l_pAscii
\r
698 getAddress of l_sUnicode to l_pUnicode
\r
700 // set the length of cchWideChar to -1 and function assumes null termination and calculates length itsself
\r
701 move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,0,0,0,0)) to l_iCharsNeeded
\r
702 move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,l_pAscii,l_iCharsNeeded,0,0)) to l_iThrow
\r
704 function_return (cstring(l_sAscii))
\r
707 // Attempt to convert a string from ASCII to unicode via MultiByteToWideChar
\r
708 function to_unicode global string argv returns string
\r
709 local string l_sAscii l_sUnicode
\r
710 local pointer l_pAscii l_pUnicode
\r
711 local integer l_iCharsNeeded l_iThrow
\r
712 move (trim(argv)) to l_sAscii
\r
714 if (l_sAscii <> "") begin
\r
715 zerostring (length(l_sAscii)*2) to l_sUnicode
\r
716 getAddress of l_sUnicode to l_pUnicode
\r
717 getAddress of l_sAscii to l_pAscii
\r
719 // set the length of cchWideChar to -1 and function assumes null termination and calculates length itsself
\r
720 move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,0,0,0,0)) to l_iCharsNeeded
\r
721 move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow
\r
723 function_return (cstring(l_sUnicode))
\r
726 // Attempt to convert a string from ascii to UTF8 via WideCharToMultiByte
\r
727 function to_utf8 global string argv returns string
\r
728 local string l_sUTF8 l_sUnicode
\r
729 local pointer l_pUTF8 l_pUnicode
\r
730 local integer l_iCharsNeeded l_iThrow
\r
731 move (trim(argv)) to l_sUnicode
\r
733 if (l_sUnicode <> "") begin
\r
734 zerostring (length(l_sUnicode)) to l_sUTF8
\r
735 getAddress of l_sUTF8 to l_pUTF8
\r
736 getAddress of l_sUnicode to l_pUnicode
\r
738 // set the length of cchWideChar to -1 and function assumes null termination and calculates lenght itsself
\r
739 move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,0,0,0,0)) to l_iCharsNeeded
\r
740 move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow
\r
743 function_return (cstring(l_sUTF8))
\r
746 // https://msdn.microsoft.com/en-us/library/windows/desktop/ms647473%28v=vs.85%29.aspx
\r
747 // Note security considerations, as this function doesn't enforce string lengths
\r
748 function ansi_to_oem global string argv returns string
\r
749 local string l_sOem l_sAnsi
\r
750 local pointer l_pOem l_pAnsi
\r
751 local integer l_iResult
\r
753 if (length(argv) <> 0) begin
\r
754 move argv to l_sAnsi
\r
755 getaddress of l_sAnsi to l_pAnsi
\r
756 zerostring (length(l_sAnsi)+1) to l_sOem
\r
757 getaddress of l_sOem to l_pOem
\r
758 move (CharToOem(l_pAnsi, l_pOem)) to l_iResult
\r
761 move argv to l_sOem
\r
763 function_return (cstring(l_sOem))
\r
766 // https://msdn.microsoft.com/en-us/library/windows/desktop/ms647493%28v=vs.85%29.aspx
\r
767 // Note security considerations, as this function doesn't enforce string lengths
\r
768 function oem_to_ansi global string argv returns string
\r
769 local string l_sOem l_sAnsi
\r
770 local pointer l_pOem l_pAnsi
\r
771 local integer l_iResult
\r
773 if (length(argv) <> 0) begin
\r
774 move argv to l_sOem
\r
775 getaddress of l_sOem to l_pOem
\r
776 zerostring (length(l_sOem)+1) to l_sAnsi
\r
777 getaddress of l_sAnsi to l_pAnsi
\r
778 move (CharToOem(l_pOem, l_pAnsi)) to l_iResult
\r
781 move argv to l_sAnsi
\r
783 function_return (cstring(l_sAnsi))
\r
786 // Get running processes on the system
\r
787 // http:// msdn2.microsoft.com/en-us/library/ms682629.aspx
\r
788 // in progress - currently churns out list of process id's to screen
\r
789 function get_procs global integer argv returns integer
\r
790 local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules
\r
791 local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid
\r
792 local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules
\r
793 local handle l_hProcess
\r
795 move (1024*10) to l_iBytes
\r
796 zerostring l_iBytes to l_sProcesses
\r
797 move 0 to l_iBytesBack
\r
799 getAddress of l_sProcesses to l_pProcesses
\r
800 zerotype _STRUCTBYTESBACK to l_sStructBytesBack
\r
801 getaddress of l_sStructBytesBack to l_pBytesBack
\r
803 move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow
\r
805 getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack
\r
807 if (mod(l_iBytesBack,4) = 0) begin
\r
808 for l_i from 1 to (l_iBytesBack/4)
\r
809 move (left(l_sProcesses,4)) to l_sBuf
\r
810 move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses
\r
811 getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid
\r
812 move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess
\r
814 move 1024 to l_iBytes2
\r
815 zerostring l_iBytes2 to l_sModules
\r
816 getAddress of l_sModules to l_pModules
\r
817 zerotype _STRUCTBYTESBACK to l_sStructBytesBack
\r
818 getaddress of l_sStructBytesBack to l_pBytesBack2
\r
820 move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow
\r
821 getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2
\r
824 showln l_i " PROC=" l_iPid " BYTES=" l_iBytesBack2 " H=" l_hProcess " LERR=" (GetLastError())
\r
826 // showln l_iBytesBack2 " " l_hProcess
\r
827 if (mod(l_iBytesBack2,4) = 0) begin
\r
828 for l_j from 1 to (l_iBytesBack2/4)
\r
829 move (left(l_sModules,4)) to l_sBuf
\r
830 move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules
\r
831 getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid
\r
835 move (CloseHandle(l_hProcess)) to l_iThrow
\r
841 showln "BYTES " l_iBytesBack
\r
846 // Returns the current system time via the GetSystemTime call
\r
847 // Takes an integer value;
\r
848 // 1 - displays individual segments comma separated
\r
849 // 0 - displays a formatted date time
\r
850 function time_data global integer argv returns string
\r
851 local string sTimeData sResult sFormattedTime sFormattedDate
\r
852 local pointer pTimeData pFormattedTime pFormattedDate
\r
853 local integer iThrow iYear iMonth iDayOfWeek iDay iHour iMinute iSecond iMilliSeconds iLenCcTime iLenCcDate iDataLength
\r
855 zeroType _SYSTEMTIME to sTimeData
\r
856 getAddress of sTimeData to pTimeData
\r
857 move (GetSystemTime(pTimeData)) to iThrow
\r
859 // just return the structure comma separated
\r
860 if (argv = 1) begin
\r
861 getBuff from sTimeData at SYSTEMTIME.wYear to iYear
\r
862 getBuff from sTimeData at SYSTEMTIME.wMonth to iMonth
\r
863 getBuff from sTimeData at SYSTEMTIME.wDayOfWeek to iDayOfWeek
\r
864 getBuff from sTimeData at SYSTEMTIME.wDay to iDay
\r
865 getBuff from sTimeData at SYSTEMTIME.wHour to iHour
\r
866 getBuff from sTimeData at SYSTEMTIME.wMinute to iMinute
\r
867 getBuff from sTimeData at SYSTEMTIME.wSecond to iSecond
\r
868 getBuff from sTimeData at SYSTEMTIME.wMilliSeconds to iMilliSeconds
\r
871 append sResult iYear "," iMonth "," iDay "," iHour "," iMinute "," iSecond "," iMilliSeconds
\r
873 // give formatted date_time
\r
874 if (argv = 0) begin
\r
875 zerostring 255 to sFormattedTime
\r
876 getaddress of sFormattedTime to pFormattedTime
\r
877 move (length(sFormattedTime)) to iLenCcTime
\r
879 move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedTime, iLenCcTime)) to iDataLength
\r
881 zerostring 255 To sFormattedDate
\r
882 getaddress of sFormattedDate To pFormattedDate
\r
883 move (length(sFormattedDate)) to iLenCcDate
\r
885 move (GetDateFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedDate, iLenCcDate)) to iDataLength
\r
886 move (cstring(sFormattedDate)) to sResult
\r
887 append sResult " " (cstring(sFormattedTime)) // terminating null char removed
\r
889 function_return sResult
\r
892 // Insert zeros into the correct places to make a field x wide (similar to zeropad)
\r
893 function fill_0 global integer iValue integer iSize returns string
\r
894 local string sReturn
\r
896 move iValue to sReturn
\r
897 while (length(sReturn) < iSize)
\r
898 insert '0' in sReturn at 1
\r
901 function_return sReturn
\r
904 // Checks the runtime date format and if it's not adding on the epoch add it
\r
905 function check_date_error global string sDate returns date
\r
906 local integer iDate iY1k
\r
909 move sDate to iDate
\r
910 move 693975 to iY1k
\r
912 if (iDate < iY1k) Calc (iDate + iY1k) to iDate
\r
913 move iDate to dDate
\r
915 function_return dDate
\r
918 // Get the mod time of a file
\r
919 // This is the core of the replacement / leap year fix of GET_FILE_MOD_TIME
\r
921 // get_time(<file>, <mode>)
\r
922 // 1 = created time
\r
923 // 2 = accessed time
\r
924 // 3 = modified time
\r
926 function get_time global string sFileName integer iMode returns string
\r
927 local string sCreated sLastAccess sLastChanged sSystemTime sLocalTime sDate sTime sDateSep
\r
928 Local pointer pCreated pLastAccess pLastChanged pSystemTime pLocalTime pFileName
\r
929 Local handle hCheckFile
\r
930 Local integer iResult iVal iDateSep iDateFormat iDate4State
\r
935 getaddress of sFileName to pFileName
\r
936 move (CreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING , 0, 0)) to hCheckFile
\r
938 if (hCheckFile <> INVALID_HANDLE_VALUE) begin
\r
939 zerotype _FILETIME to sCreated
\r
940 zerotype _FILETIME to sLastAccess
\r
941 zerotype _FILETIME to sLastChanged
\r
942 zerotype _FILETIME to sLocalTime
\r
943 getAddress of sCreated to pCreated
\r
944 getAddress of sLastAccess to pLastAccess
\r
945 getAddress of sLastChanged to pLastChanged
\r
946 getAddress of sLocalTime to pLocalTime
\r
948 move (GetFileTime (hCheckFile, pCreated, pLastAccess, pLastChanged)) to iResult
\r
951 if (iMode = 1) move (FileTimeToLocalFileTime(pCreated,pLocalTime)) to iResult
\r
952 else if (iMode = 2) move (FileTimeToLocalFileTime(pLastAccess, pLocalTime)) to iResult
\r
953 else if (iMode = 3) move (FileTimeToLocalFileTime(pLastChanged, pLocalTime)) to iResult
\r
955 zerotype _SYSTEMTIME2 to sSystemTime
\r
956 getAddress of sSystemTime to pSystemTime
\r
958 move (FileTimeToSystemTime(pLocalTime, pSystemTime)) to iResult
\r
960 get_attribute DF_DATE_SEPARATOR to iDateSep
\r
961 move (character(iDateSep)) to sDateSep
\r
962 get_attribute DF_DATE_FORMAT to iDateFormat
\r
964 if (iDateFormat = DF_DATE_USA) begin
\r
965 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal
\r
966 append sDate (fill_0(iVal,2))
\r
967 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal
\r
968 append sDate sDateSep (fill_0(iVal,2))
\r
969 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal
\r
970 append sDate sDateSep (fill_0(iVal,4))
\r
972 else if iDateFormat eq DF_DATE_EUROPEAN begin
\r
973 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal
\r
974 append sDate (fill_0(iVal,2))
\r
975 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal
\r
976 append sDate sDateSep (fill_0(iVal,2))
\r
977 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal
\r
978 append sDate sDateSep (fill_0(iVal,4))
\r
980 else if iDateFormat eq DF_DATE_MILITARY begin
\r
981 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal
\r
982 append sDate (fill_0(iVal,4))
\r
983 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal
\r
984 append sDate sDateSep (fill_0(iVal,2))
\r
985 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal
\r
986 append sDate sDateSep (fill_0(iVal,2))
\r
989 getbuff from sSystemTime at SYSTEMTIME2.wHour to iVal
\r
990 append sTime (fill_0(iVal,2))
\r
991 getbuff from sSystemTime at SYSTEMTIME2.wMinute to iVal
\r
992 append sTime ":" (fill_0(iVal,2))
\r
993 getbuff from sSystemTime at SYSTEMTIME2.wSecond to iVal
\r
994 append sTime ":" (fill_0(iVal,2))
\r
998 move (CloseHandle (hCheckFile)) to iResult
\r
1001 function_return sDate
\r
1004 // Create a guid GUID (Microsoft)
\r
1005 function create_guid global returns string
\r
1006 local integer l_iThrow
\r
1007 local pointer l_ptGUID l_ptGUIDString
\r
1008 local string l_stGUID l_stGUIDString l_sResult
\r
1010 zerotype _GUID to l_stGUID
\r
1011 getaddress of l_stGUID to l_ptGUID
\r
1013 zerostring GUID_STRING_LENGTH to l_stGUIDString
\r
1014 getaddress of l_stGUIDString to l_ptGUIDString
\r
1016 if (CoCreateGuid(l_ptGUID) = 0) begin
\r
1017 // If successfully created put it in a string
\r
1018 move (StringFromGUID2(l_ptGUID, l_ptGUIDString, GUID_STRING_LENGTH)) to l_iThrow
\r
1019 move (cstring(to_ascii(l_stGUIDString))) to l_sResult
\r
1022 function_return l_sResult
\r
1025 // Get textual description of a win32 error returned by GetLastError()
\r
1026 function get_last_error_detail global integer iError returns string
\r
1027 local integer l_iThrow
\r
1028 local string l_sBuf
\r
1029 local pointer l_pBuf
\r
1031 zerostring 200 to l_sBuf
\r
1032 getaddress of l_sBuf to l_pBuf
\r
1034 move (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, iError, LANG_NEUTRAL, l_pBuf, 200, 0)) to l_iThrow
\r
1036 function_return (string(iError)+": "+l_sBuf)
\r
1039 // Get system disk info
\r
1040 // argv1 = disk mount point i.e. c:\
\r
1041 // argv2 = "" or "TOTAL", where TOTAL returns free and blank displays used.
\r
1042 function disk_info global string argv string argv2 returns number
\r
1043 local string l_sSectorsPerCluster l_sBytesPerSector l_sNumberOfFreeClusters l_sTotalNumberOfClusters
\r
1044 local pointer l_pSectorsPerCluster l_pBytesPerSector l_pNumberOfFreeClusters l_pTotalNumberOfClusters
\r
1045 local number l_iSectorsPerCluster l_iBytesPerSector l_iNumberOfFreeClusters l_iTotalNumberOfClusters l_iSpace
\r
1047 move 0 to l_iSpace
\r
1049 if (argv <> "") begin
\r
1050 zerotype _DISKDATA1 to l_sSectorsPerCluster
\r
1051 zerotype _DISKDATA2 to l_sBytesPerSector
\r
1052 zerotype _DISKDATA3 to l_sNumberOfFreeClusters
\r
1053 zerotype _DISKDATA4 to l_sTotalNumberOfClusters
\r
1055 getaddress of l_sSectorsPerCluster to l_pSectorsPerCluster
\r
1056 getaddress of l_sBytesPerSector to l_pBytesPerSector
\r
1057 getaddress of l_sNumberOfFreeClusters to l_pNumberOfFreeClusters
\r
1058 getaddress of l_sTotalNumberOfClusters to l_pTotalNumberOfClusters
\r
1060 showln (GetDiskFreeSpace(argv, l_pSectorsPerCluster, l_pBytesPerSector, l_pNumberOfFreeClusters, l_pTotalNumberOfClusters))
\r
1062 getbuff from l_sSectorsPerCluster at DISKDATA1.sectorsPerCluster to l_iSectorsPerCluster
\r
1063 getbuff from l_sBytesPerSector at DISKDATA2.bytesPerSector to l_iBytesPerSector
\r
1064 getbuff from l_sNumberOfFreeClusters at DISKDATA3.numberOfFreeClusters to l_iNumberOfFreeClusters
\r
1065 getbuff from l_sTotalNumberOfClusters at DISKDATA4.totalNumberOfClusters to l_iTotalNumberOfClusters
\r
1067 // showln l_iSectorsPerCluster
\r
1068 // showln l_iBytesPerSector
\r
1069 // showln l_iNumberOfFreeClusters
\r
1070 // showln l_iTotalNumberOfClusters
\r
1072 if (argv2 = "TOTAL") calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iTotalNumberOfClusters) to l_iSpace
\r
1073 else calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iNumberOfFreeClusters) to l_iSpace
\r
1076 function_return l_iSpace
\r
1079 // Get system memory usage
\r
1080 function get_mem_usage global returns integer
\r
1081 local integer l_iThrow l_iPid l_iMem
\r
1082 local string l_sProcessMemoryCounters
\r
1083 local pointer l_lpProcessMemoryCounters
\r
1084 local handle l_hProcess
\r
1086 zeroType _PROCESS_MEMORY_COUNTERS to l_sProcessMemoryCounters
\r
1087 getaddress of l_sProcessMemoryCounters to l_lpProcessMemoryCounters
\r
1089 put (length(l_sProcessMemoryCounters)) to l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.cb
\r
1091 move (get_process_id(0)) to l_iPid
\r
1092 move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess
\r
1094 move (GetProcessMemoryInfo(l_hProcess, l_lpProcessMemoryCounters, length(l_sProcessMemoryCounters))) to l_iThrow
\r
1095 getbuff from l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.WorkingSetSize to l_iMem
\r
1097 // showln l_hProcess " " l_iThrow
\r
1098 // showln (GetLastError())
\r
1099 // showln (get_last_error_detail(GetLastError()))
\r
1101 function_return l_iMem
\r
1104 // Uses Microsofts InternetCanonicalizeUrl functionality
\r
1105 // http:// msdn.microsoft.com/en-us/library/windows/desktop/aa384342%28v=vs.85%29.aspx
\r
1106 // https:// groups.google.com/forum/#!topic/microsoft.public.vb.winapi/0RY8jPsx_14
\r
1107 function urldecode global string argv returns string
\r
1108 local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult
\r
1109 local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength
\r
1110 local integer l_iwBufferLength l_iResult l_iDllErr
\r
1112 move argv to l_szUrl
\r
1113 move argv to l_sResult
\r
1115 if (length(l_szUrl) > 0) begin
\r
1116 zerostring ((length(l_szUrl))+1) to l_szBuffer
\r
1117 getaddress of l_szUrl to l_lpszUrl
\r
1118 getaddress of l_szBuffer to l_lpszBuffer
\r
1120 zerotype _STRUCTBYTESREAD to l_szStructBytesRead
\r
1121 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
1122 getaddress of l_szStructBytesRead to l_lpdwBufferLength
\r
1124 move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_NO_ENCODE+ICU_DECODE)) to l_iResult
\r
1126 getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength
\r
1128 if (l_iResult <> 1) begin
\r
1129 move (GetLastError()) to l_iDllErr
\r
1130 custom_error ERROR_CODE_URLDECODE$ ERROR_MSG_URLDECODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))
\r
1132 move (cstring(l_szBuffer)) to l_sResult
\r
1134 function_return l_sResult
\r
1137 // Uses Microsofts InternetCanonicalizeUrl functionality
\r
1138 // Only encodes parts before ? and #
\r
1139 function urlencode global string argv returns string
\r
1140 local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult
\r
1141 local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength
\r
1142 local integer l_iwBufferLength l_iResult l_iDllErr
\r
1144 move argv to l_szUrl
\r
1145 move argv to l_sResult
\r
1146 if (length(l_szUrl) > 0) begin
\r
1147 zerostring ((length(l_szUrl))+1) to l_szBuffer
\r
1148 getaddress of l_szUrl to l_lpszUrl
\r
1149 getaddress of l_szBuffer to l_lpszBuffer
\r
1151 zerotype _STRUCTBYTESREAD to l_szStructBytesRead
\r
1152 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
1153 getaddress of l_szStructBytesRead to l_lpdwBufferLength
\r
1155 move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_BROWSER_MODE)) to l_iResult
\r
1157 getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength
\r
1159 if (l_iResult <> 1) begin
\r
1160 move (GetLastError()) to l_iDllErr
\r
1161 custom_error ERROR_CODE_URLENCODE$ ERROR_MSG_URLENCODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))
\r
1163 move (cstring(l_szBuffer)) to l_sResult
\r
1165 function_return l_sResult
\r
1168 // Functions to pull windows os version string
\r
1169 function get_os_version global returns string
\r
1170 local string l_sOsInfo l_sVersion l_sReturn
\r
1171 local pointer l_pOsInfo
\r
1172 local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform
\r
1174 move "" to l_sVersion
\r
1176 zerotype _OSVERSIONINFO to l_sOsInfo
\r
1177 put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize
\r
1178 getaddress of l_sOsInfo to l_pOsInfo
\r
1180 move (GetVersionEx(l_pOsInfo)) to l_iResult
\r
1182 if (l_iResult = 1) begin
\r
1183 getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor
\r
1184 getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor
\r
1185 getbuff from l_sOsInfo at OSVERSIONINFO.dwBuildNumber to l_iBuild
\r
1186 getbuff from l_sOsInfo at OSVERSIONINFO.dwPlatformId to l_iPlatform
\r
1187 // getbuff from l_sOsInfo at OSVERSIONINFO.szCSDVersion to l_sVersion !??
\r
1188 move (cstring(right(l_sOsInfo,128))) to l_sVersion
\r
1191 move ("Windows Version: "+string(l_iMajor)+"."+string(l_iMinor)+" Build: "+string(l_iBuild)+" Platform: "+string(l_iPlatform)+" CSDVersion: "+l_sVersion) to l_sReturn
\r
1193 function_return l_sReturn
\r
1196 // Functions to pull windows os version as a numeric value
\r
1197 function get_os_version_numeric global returns number
\r
1198 local string l_sOsInfo l_sVersion
\r
1199 local pointer l_pOsInfo
\r
1200 local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform
\r
1202 move "" to l_sVersion
\r
1204 zerotype _OSVERSIONINFO to l_sOsInfo
\r
1205 put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize
\r
1206 getaddress of l_sOsInfo to l_pOsInfo
\r
1208 move (GetVersionEx(l_pOsInfo)) to l_iResult
\r
1210 if (l_iResult = 1) begin
\r
1211 getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor
\r
1212 getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor
\r
1215 function_return (number(l_iMajor)+(number(l_iMinor)/10))
\r
1218 // Converts binary to hex or base64 strings and vice versa
\r
1219 function binary_to_string_to_binary global string argv string argv2 string argv3 returns string
\r
1220 local string l_sData l_sDataDecoded l_sDataSizeDecoded l_sReturn
\r
1221 local pointer l_pData l_pDataDecoded l_pDataSizeDecoded
\r
1222 local integer l_iResult l_iDataSize l_iDataSizeDecoded l_iOffset
\r
1224 move argv to l_sData
\r
1225 move (length(l_sData)) to l_iDataSize
\r
1226 getaddress of l_sData to l_pData
\r
1228 zerostring ((length(l_sData)*4)+1) to l_sDataDecoded
\r
1229 getaddress of l_sDataDecoded to l_pDataDecoded
\r
1231 zerotype _DW_TYPE to l_sDataSizeDecoded
\r
1232 put (length(l_sDataDecoded)) to l_sDataSizeDecoded at DW_TYPE.value
\r
1233 getaddress of l_sDataSizeDecoded to l_pDataSizeDecoded
\r
1236 case (argv2 = "HEX") begin
\r
1237 if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult
\r
1238 if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult
\r
1241 case (argv2 = "BASE64") begin
\r
1242 if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult
\r
1243 if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult
\r
1246 case else custom_error ERROR_CODE_UNKNOWN_FORMAT$ ERROR_MSG_UNKNOWN_FORMAT argv2
\r
1249 getbuff from l_sDataSizeDecoded at DW_TYPE.value to l_iDataSizeDecoded
\r
1251 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1252 showln "ERROR: " (ternary(argv3 = 0, "CryptBinaryToString", "CryptStringToBinary")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1253 showln "DATA = " l_sDataDecoded
\r
1254 showln "SIZE = " l_iDataSizeDecoded
\r
1257 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
1258 else move (cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset))) to l_sReturn
\r
1261 function_return l_sReturn
\r
1264 // Convert binary data to hex or base64
\r
1265 function binary_to_string global string argv string argv2 returns string
\r
1266 function_return (binary_to_string_to_binary(argv, argv2, 0))
\r
1268 // Convert hex or base64 strings to binary data
\r
1269 function string_to_binary global string argv string argv2 returns string
\r
1270 function_return (binary_to_string_to_binary(argv, argv2, 1))
\r
1273 // List out cryptographic providers on ms windows
\r
1274 function ms_adv_listproviders global returns integer
\r
1275 local integer l_i l_iResult l_iType
\r
1276 local string l_sType l_sName l_sNameSize
\r
1277 local pointer l_pType l_pName l_pNameSize
\r
1283 zerotype _DW_TYPE to l_sType
\r
1284 getaddress of l_sType to l_pType
\r
1286 zerostring 255 to l_sName
\r
1287 getaddress of l_sName to l_pName
\r
1289 zerotype _DW_TYPE to l_sNameSize
\r
1290 put length(l_sName) to l_sNameSize at DW_TYPE.value
\r
1291 getaddress of l_sNameSize to l_pNameSize
\r
1293 move (CryptEnumProviders(l_i, HEXNULL, 0, l_pType, l_pName, l_pNameSize)) to l_iResult
\r
1295 if ((l_iResult <> 1) and (GetLastError() <> 0) and (GetLastError() <> 259)) begin
\r
1296 showln "ERROR: " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1298 getbuff from l_sType at DW_TYPE.value to l_iType
\r
1300 if (l_iResult = 1) showln l_i ") " l_iType " - '" (cstring(l_sName)) "'"
\r
1301 until (l_iResult <> 1)
\r
1305 //-------------------------------------------------------------------------
\r
1307 //-------------------------------------------------------------------------
\r
1309 // Object to provide basic implimentations of some popular hash algorithms and encryption
\r
1310 // provided by the Microsoft Cryptographic Provider
\r
1312 // Send message methods:
\r
1314 // aquire_context - Create the context of the Microsoft CSP
\r
1315 // release_context - Release the context of the Microsoft CSP
\r
1316 // import_key <key> <ealg> - Incomplete/WIP
\r
1317 // derive_key <psw> <halg> <ealg>- Derives an encryption key provider when supplied
\r
1318 // with a password, a hash algorithm and the required
\r
1320 // modify_key_iv <iv> - Set the initilization vector of the key provider
\r
1321 // modify_key_mode <mode> - Set the key provider mode E.g. CBC, ECB etc
\r
1322 // destroy_key - Dispose of the current key provider
\r
1325 // hash_data <data> <halg> - Returns a hash of the passed data in the specified
\r
1327 // export_key - Returns the current encryption key
\r
1328 // generate_random_key_iv - Generates and sets a random initilization vector
\r
1329 // for the key provider
\r
1330 // encrypt <data> - Encrypt data
\r
1331 // decrypt <data> - Decrypt data
\r
1335 // object test is an msAdvCrypt
\r
1337 // string data buf
\r
1339 // // Generate a hash
\r
1340 // send aquire_context to test
\r
1341 // get hash_data of test "MYTEXT" "SHA1" to data
\r
1342 // send release_context to test
\r
1343 // showln "HASHED: " (binary_to_string(data,"HEX"))
\r
1345 // // Encrypt 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 // get generate_random_key_iv of test to buf
\r
1350 // move buf to data
\r
1351 // get encrypt of test "MYDATA" to buf
\r
1352 // append data buf
\r
1353 // send destroy_key to test
\r
1354 // send release_context to test
\r
1355 // showln "ENCRYPTED: " (binary_to_string(data,"HEX"))
\r
1357 // // Decrypt some data
\r
1358 // send aquire_context to test
\r
1359 // send derive_key to test "MYPASSWORD" "SHA256" "AES_256"
\r
1360 // send modify_key_mode to test "CBC"
\r
1361 // send modify_key_iv to test (mid(data,16,1))
\r
1362 // get decrypt of test (mid(data,length(data)-16,17)) to data
\r
1363 // send destroy_key to test
\r
1364 // send release_context to test
\r
1365 // showln "DECRYPTED: " data
\r
1367 class msAdvCrypt is an array
\r
1368 procedure construct_object string argc
\r
1369 forward send construct_object argc
\r
1371 property handle c_hProv
\r
1372 property handle c_hHash
\r
1373 property handle c_hKey
\r
1374 property string c_sAlg
\r
1377 procedure aquire_context
\r
1378 local integer l_iResult
\r
1379 local handle l_hProv
\r
1380 local string l_shProv
\r
1381 local pointer l_phProv
\r
1383 zerotype _DW_TYPE to l_shProv
\r
1384 getaddress of l_shProv to l_phProv
\r
1386 if (get_os_version_numeric() < 5.2) begin
\r
1387 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult
\r
1388 if (GetLastError() = -2146893802) begin
\r
1389 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult
\r
1393 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult
\r
1394 if (GetLastError() = -2146893802) begin
\r
1395 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult
\r
1399 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1400 showln "ERROR: CryptAcquireContext " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1403 getbuff from l_shProv at DW_TYPE.value to l_hProv
\r
1404 set c_hProv to l_hProv
\r
1408 function make_hash string in_data string in_hashalgorithm returns string
\r
1409 local integer l_iResult l_iHashSize
\r
1410 local string l_shHash l_sHash l_sRawString l_sHashSize
\r
1411 local handle l_hProv l_hHash
\r
1412 local pointer l_phHash l_pHash l_pRawString l_pHashSize
\r
1414 get c_hProv to l_hProv
\r
1416 if (l_hProv = 0) begin
\r
1417 custom_error ERROR_CODE_NO_CONTEXT$ ERROR_MSG_NO_CONTEXT
\r
1420 move in_data to l_sRawString
\r
1421 getaddress of l_sRawString to l_pRawString
\r
1423 zerotype _HCRYPTHASH to l_shHash
\r
1424 getaddress of l_shHash to l_phHash
\r
1427 case (in_hashalgorithm = "MD5") begin
\r
1428 move (CryptCreateHash(l_hProv, CALG_MD5, 0, 0, l_phHash)) to l_iResult
\r
1429 zerostring (128/8) to l_sHash
\r
1432 case ((in_hashalgorithm = "SHA1") or (in_HASHalgorithm = "SHA")) begin
\r
1433 move (CryptCreateHash(l_hProv, CALG_SHA1, 0, 0, l_phHash)) to l_iResult
\r
1434 zerostring (160/8) to l_sHash
\r
1437 case (in_hashalgorithm = "SHA256") begin
\r
1438 move (CryptCreateHash(l_hProv, CALG_SHA_256, 0, 0, l_phHash)) to l_iResult
\r
1439 zerostring (256/8) to l_sHash
\r
1442 case (in_hashalgorithm = "SHA384") begin
\r
1443 move (CryptCreateHash(l_hProv, CALG_SHA_384, 0, 0, l_phHash)) to l_iResult
\r
1444 zerostring (384/8) to l_sHash
\r
1447 case (in_hashalgorithm = "SHA512") begin
\r
1448 move (CryptCreateHash(l_hProv, CALG_SHA_512, 0, 0, l_phHash)) to l_iResult
\r
1449 zerostring (512/8) to l_sHash
\r
1453 custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_hashalgorithm
\r
1457 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1458 showln "ERROR: CryptCreateHash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1461 getbuff from l_shHash at HCRYPTHASH.value to l_hHash
\r
1462 getaddress of l_sHash to l_pHash
\r
1464 move (CryptHashData(l_hHash, l_pRawString, (length(l_sRawString)), 0)) to l_iResult
\r
1466 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1467 showln "ERROR: Crypthash_data " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1470 zerotype _DW_TYPE to l_sHashSize
\r
1471 put (length(l_sHash)) to l_sHashSize at DW_TYPE.value
\r
1472 getaddress of l_sHashSize to l_pHashSize
\r
1474 move (CryptGetHashParam(l_hHash, HP_HASHVAL, l_pHash, l_pHashSize, 0)) to l_iResult
\r
1476 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1477 showln "ERROR: CryptGetHashParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1480 getbuff from l_sHashSize at DW_TYPE.value to l_iHashSize
\r
1482 if (l_iHashSize <> length(l_sHash)) begin
\r
1483 showln "WARNING: Binary data does not match expected hash size:"
\r
1484 showln "DATA = " l_sHash
\r
1485 showln "SIZE = " l_iHashSize " / " (length(l_sHash))
\r
1489 set c_hHash to l_hHash
\r
1491 function_return (mid(l_sHash,l_iHashSize,1))
\r
1494 procedure destroy_hash
\r
1495 local integer l_iResult
\r
1496 local handle l_hHash
\r
1498 get c_hHash to l_hHash
\r
1500 if (l_hHash <> 0) begin
\r
1501 move (CryptDestroyHash(l_hHash)) to l_iResult
\r
1502 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1503 showln "ERROR: Cryptdestroy_hash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1505 else set c_hHash to 0
\r
1509 function hash_data string in_data string in_hashalgorithm returns string
\r
1510 local integer l_iResult
\r
1511 local string l_sHash
\r
1513 get make_hash in_data in_hashalgorithm to l_sHash
\r
1516 function_return (cstring(l_sHash))
\r
1520 procedure import_key string in_key string in_algorithm
\r
1521 local integer l_iResult
\r
1522 local string l_sBlobHeader l_sPlainTextKeyBlob l_shKey
\r
1523 local handle l_hProv l_hKey
\r
1524 local pointer l_pPlainTextKeyBlob l_phKey
\r
1526 get c_hProv to l_hProv
\r
1528 zerotype _BLOBHEADER to l_sBlobHeader
\r
1529 put PLAINTEXTKEYBLOB to l_sBlobHeader at BLOBHEADER.bType
\r
1530 put 2 to l_sBlobHeader at BLOBHEADER.bVersion
\r
1531 put 0 to l_sBlobHeader at BLOBHEADER.Reserved
\r
1534 case (in_algorithm = "DES") put CALG_DES to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1536 case (in_algorithm = "3DES") put CALG_3DES to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1538 case (in_algorithm = "3DES_112") put CALG_3DES_112 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1540 case (in_algorithm = "AES") put CALG_AES to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1542 case (in_algorithm = "AES_128") put CALG_AES_128 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1544 case (in_algorithm = "AES_192") put CALG_AES_192 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1546 case (in_algorithm = "AES_256") put CALG_AES_256 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1548 case (in_algorithm = "RC2") put CALG_RC2 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1550 case (in_algorithm = "RC4") put CALG_RC4 to l_sBlobHeader at BLOBHEADER.ALG_ID
\r
1552 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm
\r
1555 zerotype _PLAINTEXTKEYBLOB to l_sPlainTextKeyBlob
\r
1556 put l_sBlobHeader to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.BLOBHEADER
\r
1557 put (length(in_key)) to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.dwKeySize
\r
1558 put_string in_key to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.rgbKeyData
\r
1560 getaddress of l_sPlainTextKeyBlob to l_pPlainTextKeyBlob
\r
1562 zerotype _HCRYPTKEY to l_shKey
\r
1563 getaddress of l_shKey to l_phKey
\r
1565 move (CryptImportKey(l_hProv, l_pPlainTextKeyBlob, length(l_sPlainTextKeyBlob), 0, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1567 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1568 showln "ERROR: CryptImportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1571 getbuff from l_shKey at HCRYPTKEY.value to l_hKey
\r
1575 procedure derive_key string in_data string in_hashalgorithm string in_algorithm
\r
1576 local integer l_iResult
\r
1577 local handle l_hProv l_hHash l_hKey
\r
1578 local string l_sKey l_shKey
\r
1579 local pointer l_phKey
\r
1581 get c_hProv to l_hProv
\r
1582 get make_hash in_data in_hashalgorithm to l_sKey
\r
1583 get c_hHash to l_hHash
\r
1585 if (l_hHash <> 0) begin
\r
1586 zerotype _HCRYPTKEY to l_shKey
\r
1587 getaddress of l_shKey to l_phKey
\r
1589 // 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
1591 case (in_algorithm = "DES") move (CryptDeriveKey(l_hProv, CALG_DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1593 case (in_algorithm = "3DES") move (CryptDeriveKey(l_hProv, CALG_3DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1595 case (in_algorithm = "3DES_112") move (CryptDeriveKey(l_hProv, CALG_3DES_112, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1597 case (in_algorithm = "AES") move (CryptDeriveKey(l_hProv, CALG_AES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1599 case (in_algorithm = "AES_128") move (CryptDeriveKey(l_hProv, CALG_AES_128, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1601 case (in_algorithm = "AES_192") move (CryptDeriveKey(l_hProv, CALG_AES_192, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1603 case (in_algorithm = "AES_256") move (CryptDeriveKey(l_hProv, CALG_AES_256, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1605 case (in_algorithm = "RC2") move (CryptDeriveKey(l_hProv, CALG_RC2, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1607 case (in_algorithm = "RC4") move (CryptDeriveKey(l_hProv, CALG_RC4, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult
\r
1609 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm
\r
1612 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1613 showln "ERROR: CryptDeriveKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1616 getbuff from l_shKey at HCRYPTKEY.value to l_hKey
\r
1617 set c_sAlg to in_algorithm
\r
1620 set c_hKey to l_hKey
\r
1624 procedure modify_key_iv string in_iv
\r
1625 local integer l_iResult l_iBlockSize
\r
1626 local handle l_hKey
\r
1627 local string l_sIV l_sAlg
\r
1628 local pointer l_pIV
\r
1630 get c_hKey to l_hKey
\r
1631 get c_sAlg to l_sAlg
\r
1633 // Set expected block size in bytes
\r
1635 case (l_sAlg contains "DES") calc (64/8) to l_iBlockSize
\r
1637 case (l_sAlg contains "AES") calc (128/8) to l_iBlockSize
\r
1639 case (l_sAlg = "RC2") calc (64/8) to l_iBlockSize
\r
1641 case else custom_error ERROR_CODE_INCOMPATIBLE_ALGORITHM$ ERROR_MSG_INCOMPATIBLE_ALGORITHM l_sAlg
\r
1644 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
1646 move in_iv to l_sIV
\r
1647 getaddress of l_sIV to l_pIV
\r
1649 move (CryptSetKeyParam(l_hKey, KP_IV, l_pIV, 0)) to l_iResult
\r
1651 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1652 showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1657 function generate_random_key_iv returns string
\r
1658 local integer l_i l_iBlockSize
\r
1659 local string l_sIV l_sAlg
\r
1661 get c_sAlg to l_sAlg
\r
1664 if ((l_sAlg contains "DES") or (l_sAlg = "RC2")) calc (64/8) to l_iBlockSize
\r
1665 if (l_sAlg contains "AES") calc (128/8) to l_iBlockSize
\r
1667 for l_i from 1 to l_iBlockSize
\r
1668 append l_sIV (character(48+random(47)))
\r
1671 send modify_key_iv l_sIV
\r
1673 function_return l_sIV
\r
1676 procedure modify_key_mode string in_mode
\r
1677 local integer l_iResult
\r
1678 local handle l_hKey
\r
1679 local string l_sMode l_sbData
\r
1680 local pointer l_pbData
\r
1682 get c_hKey to l_hKey
\r
1685 case (in_mode contains "CBC") move CRYPT_MODE_CBC to l_sMode
\r
1687 case (in_mode contains "ECB") move CRYPT_MODE_ECB to l_sMode
\r
1689 case (in_mode contains "OFB") move CRYPT_MODE_OFB to l_sMode
\r
1691 case (in_mode contains "CFB") move CRYPT_MODE_CFB to l_sMode
\r
1693 case (in_mode contains "CTS") move CRYPT_MODE_CTS to l_sMode
\r
1695 case else custom_error ERROR_CODE_UNRECOGNISED_MODE$ ERROR_MSG_UNRECOGNISED_MODE l_sMode
\r
1698 zerotype _DW_TYPE to l_sbData
\r
1699 put l_sMode to l_sbData at DW_TYPE.value
\r
1700 getaddress of l_sbData to l_pbData
\r
1702 move (CryptSetKeyParam(l_hKey, KP_MODE, l_pbData, 0)) to l_iResult
\r
1704 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1705 showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1710 function export_key returns string
\r
1711 local integer l_iResult
\r
1712 local string l_sData l_sDataSize
\r
1713 local handle l_hKey
\r
1714 local pointer l_pData l_pDataSize
\r
1715 local integer l_iKeyBlobSize l_iDataSize
\r
1717 get c_hKey to l_hKey
\r
1719 if (l_hKey <> 0) begin
\r
1720 zerotype _PLAINTEXTKEYBLOB to l_sData
\r
1721 getaddress of l_sData to l_pData
\r
1723 zerotype _DW_TYPE to l_sDataSize
\r
1724 put (length(l_sData)) to l_sDataSize at DW_TYPE.value
\r
1725 getaddress of l_sDataSize to l_pDataSize
\r
1727 move (CryptExportKey(l_hKey, 0, PLAINTEXTKEYBLOB, 0, l_pData, l_pDataSize)) to l_iResult
\r
1728 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1729 showln "ERROR: CryptExportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1732 getbuff from l_sDataSize at DW_TYPE.value to l_iKeyBlobSize
\r
1733 getbuff from l_sData at PLAINTEXTKEYBLOB.dwKeySize to l_iDataSize
\r
1734 move (mid(l_sData,l_iDataSize,13)) to l_sData
\r
1736 if (show_debug_lines) begin
\r
1737 showln "DEBUG: Key blob Size = " l_iKeyBlobSize
\r
1740 function_return l_sData
\r
1743 function encrypt_decrypt string in_data integer in_decrypt returns string
\r
1744 local integer l_iResult l_iDataSize
\r
1745 local string l_sData l_sDataSize
\r
1746 local pointer l_pData l_pDataSize
\r
1747 local handle l_hKey
\r
1749 move in_data to l_sData
\r
1750 get c_hKey to l_hKey
\r
1752 zerotype _DW_TYPE to l_sDataSize
\r
1753 put (length(l_sData)) to l_sDataSize at DW_TYPE.value
\r
1754 getaddress of l_sDataSize to l_pDataSize
\r
1756 move (l_sData+repeat(' ',length(l_sData)*2)) to l_sData
\r
1757 getaddress of l_sData to l_pData
\r
1759 if (in_decrypt = 0) move (CryptEncrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize, length(l_sData))) to l_iResult
\r
1760 else move (CryptDecrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize)) to l_iResult
\r
1762 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1763 showln "ERROR: " (ternary(in_decrypt = 0, "CryptEncrypt", "CryptDecrypt")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1766 getbuff from l_sDataSize at DW_TYPE.value to l_iDataSize
\r
1767 move (cstring(mid(l_sData,l_iDataSize,1))) to l_sData
\r
1769 function_return l_sData
\r
1772 function encrypt string in_data returns string
\r
1773 local string l_sData
\r
1775 get encrypt_decrypt in_data 0 to l_sData
\r
1776 function_return l_sData
\r
1779 function decrypt string in_data returns string
\r
1780 local string l_sData
\r
1782 get encrypt_decrypt in_data 1 to l_sData
\r
1783 function_return l_sData
\r
1786 procedure destroy_key
\r
1787 local integer l_iResult
\r
1788 local handle l_hKey l_hHash
\r
1790 get c_hKey to l_hKey
\r
1792 if (l_hKey <> 0) begin
\r
1793 move (CryptDestroyKey(l_hKey)) to l_iResult
\r
1794 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1795 showln "ERROR: CryptDestroyKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1803 get c_hHash to l_hHash
\r
1804 if (l_hHash <> 0) send destroy_hash
\r
1808 procedure release_context
\r
1809 local integer l_iResult
\r
1810 local handle l_hProv
\r
1812 get c_hProv to l_hProv
\r
1814 if (l_hProv <> 0) begin
\r
1815 move (CryptReleaseContext(l_hProv, 0)) to l_iResult
\r
1816 if ((l_iResult <> 1) and (GetLastError() <> 0)) begin
\r
1817 showln "ERROR: Cryptrelease_context " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))
\r
1819 else set c_hProv to 0
\r
1824 procedure destory_object
\r
1825 local handle l_hProv l_hHash l_hKey
\r
1827 get c_hKey to l_hKey
\r
1828 if (l_hKey <> 0) send destroy_key
\r
1830 get c_hHash to l_hHash
\r
1831 if (l_hHash <> 0) send destroy_hash
\r
1833 get c_hProv to l_hProv
\r
1834 if (l_hProv <> 0) send release_context
\r
1836 forward send destory_object
\r
1841 //-------------------------------------------------------------------------
\r
1843 //-------------------------------------------------------------------------
\r
1845 // Used for procedural invocations of hashing and encrypting
\r
1846 object msAdvCrypt_global_obj is an msAdvCrypt
\r
1849 // Procedural one-shot use of msAdvCrypt hashing
\r
1850 function msAdvCrypt_hash global string in_data string in_hash returns string
\r
1851 local string l_sReturn
\r
1853 send aquire_context to msAdvCrypt_global_obj
\r
1854 get make_hash of msAdvCrypt_global_obj in_data in_hash to l_sReturn
\r
1855 send destroy_hash to msAdvCrypt_global_obj
\r
1856 send release_context to msAdvCrypt_global_obj
\r
1858 function_return l_sReturn
\r
1861 function sha512_hex global string in_data returns string
\r
1862 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'HEX'))
\r
1865 function sha512_base64 global string in_data returns string
\r
1866 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'BASE64'))
\r
1869 function sha384_hex global string in_data returns string
\r
1870 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'HEX'))
\r
1873 function sha384_base64 global string in_data returns string
\r
1874 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'BASE64'))
\r
1877 function sha256_hex global string in_data returns string
\r
1878 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'HEX'))
\r
1881 function sha256_base64 global string in_data returns string
\r
1882 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'BASE64'))
\r
1885 function sha1_hex global string in_data returns string
\r
1886 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'HEX'))
\r
1889 function sha1_base64 global string in_data returns string
\r
1890 function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'BASE64'))
\r
1893 function md5_hex global string in_data returns string
\r
1894 function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'HEX'))
\r
1897 function md5_base64 global string in_data returns string
\r
1898 function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'BASE64'))
\r
1901 // Procedural one-shot use of msAdvCrypt AES256 encryption (HEX)
\r
1902 function aes256_hex_enc global string in_data string in_key returns string
\r
1903 local string l_sReturn l_sBuf
\r
1905 send aquire_context to msAdvCrypt_global_obj
\r
1907 send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"
\r
1908 send modify_key_mode to msAdvCrypt_global_obj "CBC"
\r
1910 get generate_random_key_iv of msAdvCrypt_global_obj to l_sBuf
\r
1911 move l_sBuf to l_sReturn
\r
1913 get encrypt of msAdvCrypt_global_obj in_data to l_sBuf
\r
1914 append l_sReturn l_sBuf
\r
1916 send destroy_key to msAdvCrypt_global_obj
\r
1917 send release_context to msAdvCrypt_global_obj
\r
1919 function_return (binary_to_string(l_sReturn,"HEX"))
\r
1922 // Procedural one-shot use of msAdvCrypt AES256 decryption (HEX)
\r
1923 function aes256_hex_dec global string in_data string in_key returns string
\r
1924 local string l_sReturn l_sBuf
\r
1926 move (string_to_binary(in_data,"HEX")) to l_sBuf
\r
1928 send aquire_context to msAdvCrypt_global_obj
\r
1929 send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"
\r
1930 send modify_key_mode to msAdvCrypt_global_obj "CBC"
\r
1932 send modify_key_iv to msAdvCrypt_global_obj (mid(l_sBuf,16,1))
\r
1934 get decrypt of msAdvCrypt_global_obj (mid(l_sBuf,length(l_sBuf)-16,17)) to l_sReturn
\r
1936 send destroy_key to msAdvCrypt_global_obj
\r
1937 send release_context to msAdvCrypt_global_obj
\r
1939 function_return l_sReturn
\r