git.8kb.co.uk Git - dataflex/df32func/blob - src/df32/win32.inc

   1 //-------------------------------------------------------------------------\r
   2 // win32.inc\r
   3 //      This file contains DataFlex functions to provide wrappers around "Win32"\r
   4 //      API calls.  See win32.h for external function definitions.\r
   5 //\r
   6 // This file is to be included when using Win32 capabilities in df32func.mk\r
   7 //\r
   8 // Copyright (c) 2006-2015, glyn@8kb.co.uk\r
   9 // \r
  10 // df32func/win32.inc\r
  11 //-------------------------------------------------------------------------\r
  12 \r
  13 #IFDEF __win32_h__\r
  14 #ELSE\r
  15     #INCLUDE win32.h\r
  16 #ENDIF\r
  17 \r
  18 //-------------------------------------------------------------------------\r
  19 // Functions\r
  20 //-------------------------------------------------------------------------\r
  21 \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
  28 \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
  33 \r
  34     zeroType _FILETIME to sLocalFileTime\r
  35     getaddress of sLocalFileTime to lpsLocalFileTime\r
  36 \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
  41 \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
  48             \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
  54         end\r
  55     end\r
  56 end_function\r
  57 \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
  60 //\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
  64 //     \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
  70 // \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
  75     local handle hFile\r
  76     local dword dwFileSizeHigh dwFileSizeLow dwHighDateTime dwLowDateTime\r
  77 \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
  83 \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
  90 \r
  91     move -1 to iFileCount\r
  92     repeat \r
  93         // FileName\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
  97 \r
  98             // FileSize\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
 102 \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
 107    \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
 112    \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
 117 \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
 123         end\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
 128 \r
 129     function_return iFileCount\r
 130 end_function\r
 131 \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
 140     \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
 148 \r
 149     move 0 to doneSort\r
 150     if ((argv < 1) or (argv > 5)) goto sorted\r
 151 \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
 158 \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
 162         end\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
 168         end\r
 169     loop\r
 170 \r
 171     send sort_items to Win32API_sort ascending\r
 172 \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
 180 \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
 193 \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
 197 \r
 198                         move argv2 to l_j\r
 199                     end\r
 200                 end\r
 201             loop\r
 202         end\r
 203     loop\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
 215     loop\r
 216 \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
 223 \r
 224     sorted:\r
 225     function_return doneSort\r
 226 end_function\r
 227 \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
 230 //    \r
 231 //     fileOpp(<operation type>,<source file>,<dest file>)\r
 232 //     <operation name> can be any of "COPY", "DELETE", "MOVE" or "RENAME"\r
 233 //\r
 234 // Example usage:\r
 235 //\r
 236 //     fileOpp("delete","C:\FileTo.delete","")\r
 237 //     fileOpp("move","C:\Source.file","C:\Destination.file")\r
 238 //\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
 243 \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
 248 \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
 252 \r
 253         case begin\r
 254             case (argv = "COPY") put FO_COPY to sFileOp at SHFILEOPSTRUCT.wFunc\r
 255             case break\r
 256             case (argv = "PRINT") put FO_COPY to sFileOp at SHFILEOPSTRUCT.wFunc\r
 257             case break\r
 258             case (argv = "DELETE") put FO_DELETE to sFileOp at SHFILEOPSTRUCT.wFunc\r
 259             case break\r
 260             case (argv = "MOVE") put FO_MOVE to sFileOp at SHFILEOPSTRUCT.wFunc\r
 261             case break\r
 262             case (argv = "RENAME") put FO_RENAME to sFileOp at SHFILEOPSTRUCT.wFunc\r
 263             case break\r
 264         case end\r
 265 \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
 270         \r
 271         if (argv <> "DELETE") begin\r
 272             getAddress Of argv3 to lpArgv3\r
 273             put lpArgv3 to sFileOp at SHFILEOPSTRUCT.pTo\r
 274         end  \r
 275 \r
 276         case begin\r
 277             case (argv = "PRINT") put (FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT+FOF_NOERRORUI+FOF_NOCOPYSECURITYATTRIBS) to sFileOp at SHFILEOPSTRUCT.fFlags\r
 278             case break\r
 279             case else put (FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT+FOF_NOERRORUI) to sFileOp at SHFILEOPSTRUCT.fFlags\r
 280             case break\r
 281         case end\r
 282             \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
 287 \r
 288         move (SHFileOperation(lpFileOp)) to l_iResult\r
 289     end\r
 290 \r
 291     function_return l_iResult\r
 292 end_function\r
 293 \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
 299     \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
 303 \r
 304     function_return lpbuffer\r
 305 end_function\r
 306 \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
 311 \r
 312     move 255 to 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
 316     \r
 317     function_return (left(sBuffer,l_iResult))\r
 318 end_function\r
 319 \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
 325     \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
 329 \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
 333     \r
 334     function_return l_sReturn\r
 335 end_function\r
 336 \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
 340   \r
 341   move (ExitProcessEx(iReturnCode)) To iVoid\r
 342   \r
 343   function_return iVoid\r
 344 end_function\r
 345 \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
 349     \r
 350     move (GetPID()) TO iRVal\r
 351     \r
 352     function_return (Low(iRVal))\r
 353 end_function\r
 354 \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
 360 \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
 367     \r
 368     if (l_01iResult) function_return (cstring(strName)) // return with terminating null char removed\r
 369     else function_return "Unknown"\r
 370 end_function\r
 371     \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
 377 \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
 383 end_function\r
 384 \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
 390 \r
 391     zeroType _BROWSEINFO to sBrowseInfo\r
 392 \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
 397     end\r
 398 \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
 402     \r
 403     getAddress Of sBrowseInfo to lpsBrowseInfo\r
 404     getAddress Of sFolder to lpsFolder\r
 405 \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
 409 \r
 410     if (iFolderSelected = 0)  move "" to sFolder\r
 411     \r
 412     function_return (cString(sFolder)) // return with terminating null char removed\r
 413 end_function\r
 414 \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
 420     \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
 427     \r
 428     function_return (left(sShortPath,l_iResult))\r
 429 end_function\r
 430 \r
 431 // Set of function to disable close widgets of shell\r
 432 function disable_close global integer argv returns integer\r
 433     local number Ret\r
 434     local handle hWnd hMenu\r
 435 \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
 441         sleep 1\r
 442     end\r
 443     \r
 444     // find the window\r
 445     move (FindWindow(0, "DataFlex")) to hWnd\r
 446     // grab the menu\r
 447     move (GetSystemMenu(hWnd, 0)) to hMenu\r
 448     // disable the X\r
 449     if (argv = 0) move (EnableMenuItem(hMenu, SC_CLOSE, (MF_BYCOMMAND ior MF_GRAYED))) to ret\r
 450     // enable the X    \r
 451     if (argv = 1) move (EnableMenuItem(hMenu, SC_CLOSE, (MF_BYCOMMAND ior MF_ENABLED))) to ret\r
 452     \r
 453     function_return 0\r
 454 end_function\r
 455
 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
 458     local number Ret
 459     local handle hWnd
 460
 461     move (SetConsoleTitle(argv)) to strmark
 462     move (FindWindow(0, argv)) to hWnd
 463     move (ShowWindow(hWnd, argv2)) to ret
 464
 465     function_return ret
 466 end_function
 467 \r
 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
 475 \r
 476     if ((trim(argv)) <> "") begin\r
 477         move 0 to windowHandle\r
 478         move "open" to sOperation\r
 479         move argv to sFile\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
 485 \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
 490 \r
 491         move (ShellExecute(windowHandle,lpOperation,lpFile,lpParameters,lpDirectory,SW_SHOWMAXIMIZED)) to l_iResult\r
 492     end\r
 493 end_function\r
 494 \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
 512     \r
 513     zeroType _PROCESS_INFORMATION to sProcessInformation\r
 514     zeroType _STARTUPINFO to sStartupInformation\r
 515 \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
 526     \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
 535     \r
 536     put (length(sStartupInformation)) to sStartupInformation at STARTUPINFO.cb\r
 537     \r
 538     move (CreateProcess(lpApplicationName,lpCommandLine,lpProcessAttributes,lpThreadAttributes,dwCreationFlags,dwCreationFlags,lpEnvironment,lpCurrentDirectory,lpStartupInformation,lpProcessInformation)) to l_iResult\r
 539     \r
 540     getbuff from sProcessInformation at PROCESS_INFORMATION.hProcess to hProcess\r
 541     getbuff from sProcessInformation at PROCESS_INFORMATION.hThread to hThread\r
 542 \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
 550     end\r
 551     if (argv3 = 1) begin                \r
 552         move hProcess to l_sExit\r
 553         append l_sExit "|" hThread\r
 554     end\r
 555     \r
 556     function_return l_sExit\r
 557 end_function\r
 558 \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
 567     \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
 578     end\r
 579     \r
 580     function_return l_iSuccess\r
 581 end_function\r
 582 \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
 589     move -1 to l_hFile\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
 597         end\r
 598     end\r
 599     function_return l_iResult\r
 600 end_function\r
 601 \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
 607     move -1 to l_hFile\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
 616         end\r
 617     end\r
 618     function_return l_iResult\r
 619 end_function\r
 620 \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
 623 //\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
 630     \r
 631     send delete_data to Win32API_buffer\r
 632     move -1 to l_iLines\r
 633     \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
 639     move "" to l_sLine\r
 640     \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
 655                     increment l_iLines\r
 656                     set array_value of (Win32API_buffer(current_object)) item l_iLines to l_sLine\r
 657                     move "" to l_sLine\r
 658                 end\r
 659                 \r
 660             end\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
 663         end \r
 664         move (CloseHandle(l_hFile)) to l_iThrow\r
 665     end\r
 666     function_return l_iLines\r
 667 end_function\r
 668 \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
 674     \r
 675     move -1 to l_iFileSize\r
 676     \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
 682     end\r
 683     \r
 684     function_return l_iFileSize\r
 685 end_function\r
 686 \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
 694     \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
 699         \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
 703     end\r
 704     function_return (cstring(l_sAscii))\r
 705 end_function\r
 706 \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
 713     \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
 718         \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
 722     end\r
 723     function_return (cstring(l_sUnicode))  \r
 724 end_function\r
 725 \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
 732     \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
 737         \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
 741     end\r
 742     \r
 743     function_return (cstring(l_sUTF8))\r
 744 end_function\r
 745 \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
 752     \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
 759     end\r
 760     else;\r
 761         move argv to l_sOem\r
 762         \r
 763     function_return (cstring(l_sOem))\r
 764 end_function\r
 765 \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
 772     \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
 779     end\r
 780     else;\r
 781         move argv to l_sAnsi\r
 782         \r
 783     function_return (cstring(l_sAnsi))\r
 784 end_function\r
 785 \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
 794     \r
 795     move (1024*10) to l_iBytes  \r
 796     zerostring l_iBytes to l_sProcesses\r
 797     move 0 to l_iBytesBack\r
 798     \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
 802     \r
 803     move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow\r
 804 \r
 805     getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack\r
 806     \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
 813             \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
 819             \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
 822             \r
 823             // Err here            \r
 824             showln l_i  " PROC=" l_iPid " BYTES=" l_iBytesBack2 " H=" l_hProcess " LERR=" (GetLastError())\r
 825             \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
 832 \r
 833                 loop\r
 834             end\r
 835             move (CloseHandle(l_hProcess)) to l_iThrow\r
 836             \r
 837         loop\r
 838     end\r
 839         \r
 840     showln l_iThrow\r
 841     showln "BYTES " l_iBytesBack\r
 842     \r
 843     function_return 0\r
 844 end_function\r
 845 \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
 854     \r
 855     zeroType _SYSTEMTIME to sTimeData\r
 856     getAddress of sTimeData to pTimeData\r
 857     move (GetSystemTime(pTimeData)) to iThrow\r
 858     \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
 869         \r
 870         move "" to sResult\r
 871         append sResult iYear "," iMonth "," iDay "," iHour "," iMinute "," iSecond "," iMilliSeconds\r
 872     end \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
 878     \r
 879         move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedTime, iLenCcTime)) to iDataLength\r
 880 \r
 881         zerostring 255 To sFormattedDate\r
 882         getaddress of sFormattedDate To pFormattedDate\r
 883         move (length(sFormattedDate)) to iLenCcDate\r
 884     \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
 888     end\r
 889     function_return sResult\r
 890 end_function\r
 891 \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
 895 \r
 896     move iValue to sReturn\r
 897     while (length(sReturn) < iSize)\r
 898         insert '0' in sReturn at 1\r
 899     end\r
 900 \r
 901     function_return sReturn\r
 902 end_function\r
 903 \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
 907     local Date    dDate\r
 908 \r
 909     move sDate to iDate\r
 910     move 693975 to iY1k\r
 911 \r
 912     if (iDate < iY1k) Calc (iDate + iY1k) to iDate\r
 913     move iDate to dDate\r
 914 \r
 915     function_return dDate\r
 916 end_function\r
 917 \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
 920 // Usage:\r
 921 // get_time(<file>, <mode>)\r
 922 //     1 = created time\r
 923 //     2 = accessed time\r
 924 //     3 = modified time\r
 925 // \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
 931 \r
 932     move "" to sTime\r
 933     move "" to sDate\r
 934     \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
 937     \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
 947 \r
 948         move (GetFileTime (hCheckFile, pCreated, pLastAccess, pLastChanged)) to iResult \r
 949           \r
 950         if (iResult) begin\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
 954             \r
 955             zerotype _SYSTEMTIME2 to sSystemTime\r
 956             getAddress of sSystemTime to pSystemTime\r
 957 \r
 958             move (FileTimeToSystemTime(pLocalTime, pSystemTime)) to iResult\r
 959 \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
 963 \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
 971             end\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
 979             end\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
 987             end\r
 988 \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
 995 \r
 996             append sDate sTime\r
 997         end\r
 998         move (CloseHandle (hCheckFile)) to iResult\r
 999     end\r
1000 \r
1001     function_return sDate\r
1002 end_function\r
1003 \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
1009    \r
1010     zerotype _GUID to l_stGUID\r
1011     getaddress of l_stGUID to l_ptGUID\r
1012 \r
1013     zerostring GUID_STRING_LENGTH to l_stGUIDString\r
1014     getaddress of l_stGUIDString to l_ptGUIDString\r
1015     \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
1020     end\r
1021     \r
1022     function_return l_sResult\r
1023 end_function\r
1024 \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
1030     \r
1031     zerostring 200 to l_sBuf\r
1032     getaddress of l_sBuf to l_pBuf\r
1033     \r
1034     move (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, iError, LANG_NEUTRAL, l_pBuf, 200, 0)) to l_iThrow\r
1035     \r
1036     function_return (string(iError)+": "+l_sBuf)\r
1037 end_function\r
1038 \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
1046     \r
1047     move 0 to l_iSpace\r
1048 \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
1054 \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
1059 \r
1060         showln (GetDiskFreeSpace(argv, l_pSectorsPerCluster, l_pBytesPerSector, l_pNumberOfFreeClusters, l_pTotalNumberOfClusters))\r
1061 \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
1066 \r
1067         // showln l_iSectorsPerCluster\r
1068         // showln l_iBytesPerSector \r
1069         // showln l_iNumberOfFreeClusters\r
1070         // showln l_iTotalNumberOfClusters\r
1071         \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
1074     end\r
1075     \r
1076     function_return l_iSpace\r
1077 end_function\r
1078 \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
1085 \r
1086     zeroType _PROCESS_MEMORY_COUNTERS to l_sProcessMemoryCounters\r
1087     getaddress of l_sProcessMemoryCounters to l_lpProcessMemoryCounters\r
1088 \r
1089     put (length(l_sProcessMemoryCounters)) to l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.cb\r
1090 \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
1093 \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
1096     \r
1097     // showln l_hProcess " " l_iThrow\r
1098     // showln (GetLastError())\r
1099     // showln (get_last_error_detail(GetLastError()))\r
1100 \r
1101     function_return l_iMem\r
1102 end_function\r
1103 \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
1111 \r
1112     move argv to l_szUrl\r
1113     move argv to l_sResult\r
1114     \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
1119         \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
1123 \r
1124         move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_NO_ENCODE+ICU_DECODE)) to l_iResult\r
1125 \r
1126         getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
1127 \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
1131         end\r
1132         move (cstring(l_szBuffer)) to l_sResult     \r
1133     end        \r
1134     function_return l_sResult        \r
1135 end_function\r
1136 \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
1143 \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
1150         \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
1154 \r
1155         move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_BROWSER_MODE)) to l_iResult\r
1156 \r
1157         getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
1158 \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
1162         end\r
1163         move (cstring(l_szBuffer)) to l_sResult     \r
1164     end        \r
1165     function_return l_sResult        \r
1166 end_function\r
1167 \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
1173     \r
1174     move "" to l_sVersion\r
1175     \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
1179     \r
1180     move (GetVersionEx(l_pOsInfo)) to l_iResult\r
1181     \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
1189     end\r
1190     \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
1192     \r
1193     function_return l_sReturn \r
1194 end_function\r
1195 \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
1201     \r
1202     move "" to l_sVersion\r
1203     \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
1207     \r
1208     move (GetVersionEx(l_pOsInfo)) to l_iResult\r
1209     \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
1213     end\r
1214     \r
1215     function_return (number(l_iMajor)+(number(l_iMinor)/10))\r
1216 end_function\r
1217 \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
1223     \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
1227      \r
1228     zerostring ((length(l_sData)*4)+1) to l_sDataDecoded\r
1229     getaddress of l_sDataDecoded to l_pDataDecoded\r
1230             \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
1234     \r
1235     case begin\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
1239         end\r
1240         case break\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
1244         end\r
1245         case break\r
1246         case else custom_error ERROR_CODE_UNKNOWN_FORMAT$ ERROR_MSG_UNKNOWN_FORMAT argv2\r
1247     case end\r
1248 \r
1249     getbuff from l_sDataSizeDecoded at DW_TYPE.value to l_iDataSizeDecoded\r
1250 \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
1255     end\r
1256     else begin\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
1259     end\r
1260     \r
1261     function_return l_sReturn\r
1262 end_function\r
1263 \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
1267 end_function\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
1271 end_function\r
1272 \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
1278 \r
1279     move -1 to l_i\r
1280     repeat\r
1281         increment l_i\r
1282         \r
1283         zerotype _DW_TYPE to l_sType\r
1284         getaddress of l_sType to l_pType\r
1285         \r
1286         zerostring 255 to l_sName\r
1287         getaddress of l_sName to l_pName\r
1288         \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
1292     \r
1293         move (CryptEnumProviders(l_i, HEXNULL, 0, l_pType, l_pName, l_pNameSize)) to l_iResult\r
1294 \r
1295         if ((l_iResult <> 1) and (GetLastError() <> 0) and (GetLastError() <> 259)) begin\r
1296             showln "ERROR: " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1297         end\r
1298         getbuff from l_sType at DW_TYPE.value to l_iType\r
1299         \r
1300         if (l_iResult = 1) showln l_i ") " l_iType " - '" (cstring(l_sName)) "'"\r
1301     until (l_iResult <> 1)\r
1302 \r
1303 end_function\r
1304 \r
1305 //-------------------------------------------------------------------------\r
1306 // Classes\r
1307 //-------------------------------------------------------------------------\r
1308 \r
1309 // Object to provide basic implimentations of some popular hash algorithms and encryption\r
1310 // provided by the Microsoft Cryptographic Provider\r
1311 //\r
1312 // Send message methods:\r
1313 //\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
1319 //                                    encryption.\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
1323 //\r
1324 // Get methods:\r
1325 //    hash_data <data> <halg>       - Returns a hash of the passed data in the specified \r
1326 //                                    algorithm\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
1332 //\r
1333 // Example usage:\r
1334 //    \r
1335 //    object test is an msAdvCrypt\r
1336 //    end_object\r
1337 //    string data buf\r
1338 //    \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
1344 //    \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
1356 //    \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
1366 //    \r
1367 class msAdvCrypt is an array\r
1368     procedure construct_object string argc \r
1369         forward send construct_object argc\r
1370         \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
1375     end_procedure\r
1376 \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
1382         \r
1383         zerotype _DW_TYPE to l_shProv\r
1384         getaddress of l_shProv to l_phProv\r
1385         \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
1390             end\r
1391         end\r
1392         else begin\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
1396             end\r
1397         end\r
1398         \r
1399         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1400             showln "ERROR: CryptAcquireContext " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1401         end\r
1402         else begin\r
1403             getbuff from l_shProv at DW_TYPE.value to l_hProv\r
1404             set c_hProv to l_hProv\r
1405         end        \r
1406     end_procedure\r
1407     \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
1413         \r
1414         get c_hProv to l_hProv\r
1415         \r
1416         if (l_hProv = 0) begin\r
1417             custom_error ERROR_CODE_NO_CONTEXT$ ERROR_MSG_NO_CONTEXT\r
1418         end\r
1419         else begin\r
1420             move in_data to l_sRawString\r
1421             getaddress of l_sRawString to l_pRawString\r
1422             \r
1423             zerotype _HCRYPTHASH to l_shHash\r
1424             getaddress of l_shHash to l_phHash        \r
1425     \r
1426             case begin\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
1430                 end\r
1431                 case break  \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
1435                 end\r
1436                 case break\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
1440                 end\r
1441                 case break\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
1445                 end\r
1446                 case break\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
1450                 end\r
1451                 case break  \r
1452                 case else begin\r
1453                     custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_hashalgorithm\r
1454                 end\r
1455             case end        \r
1456         \r
1457             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1458                 showln "ERROR: CryptCreateHash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1459             end\r
1460         \r
1461             getbuff from l_shHash at HCRYPTHASH.value to l_hHash\r
1462             getaddress of l_sHash to l_pHash\r
1463         \r
1464             move (CryptHashData(l_hHash, l_pRawString, (length(l_sRawString)), 0)) to l_iResult\r
1465         \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
1468             end\r
1469         \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
1473     \r
1474             move (CryptGetHashParam(l_hHash, HP_HASHVAL, l_pHash, l_pHashSize, 0)) to l_iResult\r
1475         \r
1476             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1477                 showln "ERROR: CryptGetHashParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1478             end    \r
1479         \r
1480             getbuff from l_sHashSize at DW_TYPE.value to l_iHashSize\r
1481 \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
1486             end        \r
1487         end\r
1488     \r
1489         set c_hHash to l_hHash        \r
1490    \r
1491         function_return (mid(l_sHash,l_iHashSize,1))\r
1492     end_function \r
1493         \r
1494     procedure destroy_hash\r
1495         local integer l_iResult\r
1496         local handle l_hHash\r
1497         \r
1498         get c_hHash to l_hHash\r
1499 \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
1504             end        \r
1505             else set c_hHash to 0\r
1506         end        \r
1507     end_procedure\r
1508 \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
1512         \r
1513         get make_hash in_data in_hashalgorithm to l_sHash\r
1514         send destroy_hash\r
1515         \r
1516         function_return (cstring(l_sHash))\r
1517     end_function \r
1518     \r
1519     //WIP\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
1525         \r
1526         get c_hProv to l_hProv   \r
1527         \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
1532         \r
1533         case begin        \r
1534             case (in_algorithm = "DES") put CALG_DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1535             case break \r
1536             case (in_algorithm = "3DES") put CALG_3DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1537             case break \r
1538             case (in_algorithm = "3DES_112") put CALG_3DES_112 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1539             case break \r
1540             case (in_algorithm = "AES") put CALG_AES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1541             case break \r
1542             case (in_algorithm = "AES_128") put CALG_AES_128 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1543             case break \r
1544             case (in_algorithm = "AES_192") put CALG_AES_192 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1545             case break \r
1546             case (in_algorithm = "AES_256") put CALG_AES_256 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1547             case break \r
1548             case (in_algorithm = "RC2") put CALG_RC2 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1549             case break \r
1550             case (in_algorithm = "RC4") put CALG_RC4 to l_sBlobHeader at BLOBHEADER.ALG_ID        \r
1551             case break \r
1552             case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
1553         case end\r
1554         \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
1559         \r
1560         getaddress of l_sPlainTextKeyBlob to l_pPlainTextKeyBlob\r
1561         \r
1562         zerotype _HCRYPTKEY to l_shKey\r
1563         getaddress of l_shKey to l_phKey\r
1564         \r
1565         move (CryptImportKey(l_hProv, l_pPlainTextKeyBlob, length(l_sPlainTextKeyBlob), 0, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1566         \r
1567         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1568             showln "ERROR: CryptImportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1569         end\r
1570             \r
1571         getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
1572         \r
1573     end_procedure\r
1574     \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
1580         \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
1584 \r
1585         if (l_hHash <> 0) begin\r
1586             zerotype _HCRYPTKEY to l_shKey\r
1587             getaddress of l_shKey to l_phKey\r
1588 \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
1590             case begin\r
1591                 case (in_algorithm = "DES") move (CryptDeriveKey(l_hProv, CALG_DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1592                 case break \r
1593                 case (in_algorithm = "3DES") move (CryptDeriveKey(l_hProv, CALG_3DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1594                 case break \r
1595                 case (in_algorithm = "3DES_112") move (CryptDeriveKey(l_hProv, CALG_3DES_112, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1596                 case break \r
1597                 case (in_algorithm = "AES") move (CryptDeriveKey(l_hProv, CALG_AES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1598                 case break \r
1599                 case (in_algorithm = "AES_128") move (CryptDeriveKey(l_hProv, CALG_AES_128, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1600                 case break \r
1601                 case (in_algorithm = "AES_192") move (CryptDeriveKey(l_hProv, CALG_AES_192, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1602                 case break \r
1603                 case (in_algorithm = "AES_256") move (CryptDeriveKey(l_hProv, CALG_AES_256, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1604                 case break \r
1605                 case (in_algorithm = "RC2") move (CryptDeriveKey(l_hProv, CALG_RC2, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1606                 case break \r
1607                 case (in_algorithm = "RC4") move (CryptDeriveKey(l_hProv, CALG_RC4, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1608                 case break \r
1609                 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
1610             case end\r
1611             \r
1612             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1613                 showln "ERROR: CryptDeriveKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1614             end\r
1615             else begin        \r
1616                 getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
1617                 set c_sAlg to in_algorithm\r
1618             end\r
1619 \r
1620             set c_hKey to l_hKey\r
1621         end\r
1622     end_procedure\r
1623        \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
1629         \r
1630         get c_hKey to l_hKey\r
1631         get c_sAlg to l_sAlg\r
1632         \r
1633         // Set expected block size in bytes\r
1634         case begin\r
1635             case (l_sAlg contains "DES") calc (64/8) to l_iBlockSize\r
1636             case break         \r
1637             case (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
1638             case break \r
1639             case (l_sAlg = "RC2") calc (64/8) to l_iBlockSize\r
1640             case break \r
1641             case else custom_error ERROR_CODE_INCOMPATIBLE_ALGORITHM$ ERROR_MSG_INCOMPATIBLE_ALGORITHM l_sAlg\r
1642         case end\r
1643         \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
1645         \r
1646         move in_iv to l_sIV\r
1647         getaddress of l_sIV to l_pIV\r
1648         \r
1649         move (CryptSetKeyParam(l_hKey, KP_IV, l_pIV, 0)) to l_iResult\r
1650         \r
1651         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1652             showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1653         end        \r
1654         \r
1655     end_procedure\r
1656     \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
1660      \r
1661         get c_sAlg to l_sAlg\r
1662         move "" to l_sIV\r
1663         \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
1666         \r
1667         for l_i from 1 to l_iBlockSize\r
1668             append l_sIV (character(48+random(47)))\r
1669         loop\r
1670         \r
1671         send modify_key_iv l_sIV\r
1672         \r
1673         function_return l_sIV\r
1674     end_function\r
1675     \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
1681         \r
1682         get c_hKey to l_hKey\r
1683 \r
1684         case begin\r
1685             case (in_mode contains "CBC") move CRYPT_MODE_CBC to l_sMode\r
1686             case break\r
1687             case (in_mode contains "ECB") move CRYPT_MODE_ECB to l_sMode\r
1688             case break\r
1689             case (in_mode contains "OFB") move CRYPT_MODE_OFB to l_sMode\r
1690             case break\r
1691             case (in_mode contains "CFB") move CRYPT_MODE_CFB to l_sMode\r
1692             case break\r
1693             case (in_mode contains "CTS") move CRYPT_MODE_CTS to l_sMode\r
1694             case break            \r
1695             case else custom_error ERROR_CODE_UNRECOGNISED_MODE$ ERROR_MSG_UNRECOGNISED_MODE l_sMode        \r
1696         case end\r
1697         \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
1701         \r
1702         move (CryptSetKeyParam(l_hKey, KP_MODE, l_pbData, 0)) to l_iResult\r
1703         \r
1704         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1705             showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1706         end        \r
1707     \r
1708     end_procedure\r
1709     \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
1716         \r
1717         get c_hKey to l_hKey\r
1718         \r
1719         if (l_hKey <> 0) begin\r
1720             zerotype _PLAINTEXTKEYBLOB to l_sData\r
1721             getaddress of l_sData to l_pData\r
1722         \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
1726         \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
1730             end \r
1731         \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
1735             \r
1736             if (show_debug_lines) begin\r
1737                 showln "DEBUG: Key blob Size = " l_iKeyBlobSize        \r
1738             end\r
1739        end\r
1740        function_return l_sData\r
1741     end_function\r
1742     \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
1748         \r
1749         move in_data to l_sData    \r
1750         get c_hKey to l_hKey\r
1751         \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
1755         \r
1756         move (l_sData+repeat(' ',length(l_sData)*2)) to l_sData\r
1757         getaddress of l_sData to l_pData        \r
1758         \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
1761 \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
1764         end\r
1765         \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
1768         \r
1769         function_return l_sData\r
1770     end_function\r
1771     \r
1772     function encrypt string in_data returns string\r
1773         local string l_sData\r
1774         \r
1775         get encrypt_decrypt in_data 0 to l_sData\r
1776         function_return l_sData\r
1777     end_function\r
1778     \r
1779     function decrypt string in_data returns string\r
1780         local string l_sData\r
1781         \r
1782         get encrypt_decrypt in_data 1 to l_sData\r
1783         function_return l_sData\r
1784     end_function\r
1785     \r
1786     procedure destroy_key\r
1787         local integer l_iResult\r
1788         local handle l_hKey l_hHash\r
1789         \r
1790         get c_hKey to l_hKey\r
1791         \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
1796             end  \r
1797             else begin\r
1798                 set c_hKey to 0\r
1799                 set c_sAlg to ""\r
1800             end\r
1801         end\r
1802         \r
1803         get c_hHash to l_hHash\r
1804         if (l_hHash <> 0) send destroy_hash        \r
1805         \r
1806     end_procedure\r
1807     \r
1808     procedure release_context\r
1809         local integer l_iResult\r
1810         local handle l_hProv  \r
1811         \r
1812         get c_hProv to l_hProv\r
1813     \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
1818             end    \r
1819             else set c_hProv to 0\r
1820         end\r
1821         \r
1822     end_procedure\r
1823     \r
1824     procedure destory_object\r
1825         local handle l_hProv l_hHash l_hKey\r
1826         \r
1827         get c_hKey to l_hKey\r
1828         if (l_hKey <> 0) send destroy_key\r
1829         \r
1830         get c_hHash to l_hHash\r
1831         if (l_hHash <> 0) send destroy_hash\r
1832         \r
1833         get c_hProv to l_hProv\r
1834         if (l_hProv <> 0) send release_context\r
1835              \r
1836         forward send destory_object\r
1837     end_procedure\r
1838         \r
1839 end_class\r
1840 \r
1841 //-------------------------------------------------------------------------\r
1842 // Functions\r
1843 //-------------------------------------------------------------------------\r
1844 \r
1845 // Used for procedural invocations of hashing and encrypting\r
1846 object msAdvCrypt_global_obj is an msAdvCrypt\r
1847 end_object\r
1848 \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
1852    \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
1857     \r
1858     function_return l_sReturn\r
1859 end_function\r
1860 \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
1863 end_function\r
1864 \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
1867 end_function\r
1868 \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
1871 end_function\r
1872 \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
1875 end_function\r
1876 \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
1879 end_function\r
1880 \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
1883 end_function\r
1884 \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
1887 end_function\r
1888 \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
1891 end_function\r
1892 \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
1895 end_function\r
1896 \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
1899 end_function\r
1900 \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
1904    \r
1905     send aquire_context to msAdvCrypt_global_obj\r
1906     \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
1909     \r
1910     get generate_random_key_iv of msAdvCrypt_global_obj to l_sBuf    \r
1911     move l_sBuf to l_sReturn\r
1912     \r
1913     get encrypt of msAdvCrypt_global_obj in_data to l_sBuf\r
1914     append l_sReturn l_sBuf\r
1915     \r
1916     send destroy_key to msAdvCrypt_global_obj    \r
1917     send release_context to msAdvCrypt_global_obj\r
1918     \r
1919     function_return (binary_to_string(l_sReturn,"HEX"))\r
1920 end_function\r
1921 \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
1925    \r
1926     move (string_to_binary(in_data,"HEX")) to l_sBuf\r
1927    \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
1931     \r
1932     send modify_key_iv to msAdvCrypt_global_obj (mid(l_sBuf,16,1))\r
1933     \r
1934     get decrypt of msAdvCrypt_global_obj (mid(l_sBuf,length(l_sBuf)-16,17)) to l_sReturn\r
1935     \r
1936     send destroy_key to msAdvCrypt_global_obj    \r
1937     send release_context to msAdvCrypt_global_obj\r
1938     \r
1939     function_return l_sReturn\r
1940 end_function\r