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 \r
 456 // This function will run any external application directly from dataflex\r
 457 // argv = application to run (command name/path) argv2 = any parameters to pass to the program argv3 = directory to run from\r
 458 function shell_exec global string argv string argv2 string argv3 returns integer\r
 459     local handle windowHandle\r
 460     local pointer lpOperation lpFile lpParameters lpDirectory\r
 461     local integer nShowCmd l_iResult\r
 462     local string sOperation sFile sParameters sDirectory\r
 463 \r
 464     if ((trim(argv)) <> "") begin\r
 465         move 0 to windowHandle\r
 466         move "open" to sOperation\r
 467         move argv to sFile\r
 468         if ((trim(argv2)) <> "") move argv2 to sParameters\r
 469         else move "" to sParameters \r
 470         if ((trim(argv3)) <> "") move argv3 to sDirectory\r
 471         else move "" to sDirectory\r
 472         move "" to sDirectory\r
 473 \r
 474         getAddress of sOperation to lpOperation\r
 475         getAddress of sFile to lpFile\r
 476         getAddress of sParameters to lpParameters\r
 477         getAddress of sDirectory to lpDirectory\r
 478 \r
 479         move (ShellExecute(windowHandle,lpOperation,lpFile,lpParameters,lpDirectory,SW_SHOWMAXIMIZED)) to l_iResult\r
 480     end\r
 481 end_function\r
 482 \r
 483 // This function will run the console application stated in argv1\r
 484 // argv2 = set to 1 to run the process in a new window\r
 485 // argv3 = set to 1 to leave the new process running and continue without killing it\r
 486 // argv4  = The time to live before killing the process - set to zero to wait until finished\r
 487 // Note - Setting argv3 to 1 will result in build up of open handles for finished processes \r
 488 //        if term_proc is not used to terminate the process.\r
 489 // It is possible to have multiple processes running in one window by\r
 490 // setting argv2 = 0 and argv3 = 1, but handling how they behave on the screen \r
 491 // requires some careful fiddling.\r
 492 function create_proc global string argv integer argv2 integer argv3 integer argv4 returns string\r
 493     local pointer lpProcessInformation lpStartupInformation\r
 494     local integer l_iResult\r
 495     local pointer lpApplicationName lpCommandLine lpProcessAttributes lpThreadAttributes lpEnvironment lpCurrentDirectory\r
 496     local integer bInheritHandles iProcessAttributes iThreadAttributes iEnvironment \r
 497     local dword dwCreationFlags dwMilliseconds\r
 498     local string sProcessInformation sStartupInformation sApplicationName sCommandLine sCurrentDirectory l_sExit l_sTmp\r
 499     local handle hProcess hThread\r
 500     \r
 501     zeroType _PROCESS_INFORMATION to sProcessInformation\r
 502     zeroType _STARTUPINFO to sStartupInformation\r
 503 \r
 504     move STRINGNULL to l_sExit\r
 505     move STRINGNULL to sApplicationName\r
 506     move argv to sCommandLine\r
 507     move HEXNULL to iProcessAttributes\r
 508     move HEXNULL to iThreadAttributes\r
 509     move HEXTRUE to bInheritHandles\r
 510     move HEXNULL to iEnvironment\r
 511     move STRINGNULL to sCurrentDirectory\r
 512     if (argv2 = 0) move NORMAL_PRIORITY_CLASS to dwCreationFlags\r
 513     if (argv2 = 1) move (CREATE_NEW_CONSOLE+NORMAL_PRIORITY_CLASS) to dwCreationFlags\r
 514     \r
 515     getaddress of sApplicationName to lpApplicationName\r
 516     getaddress of sCommandLine to lpCommandLine\r
 517     getaddress of iProcessAttributes to lpProcessAttributes\r
 518     getaddress of iThreadAttributes to lpThreadAttributes\r
 519     getaddress of iEnvironment to lpEnvironment\r
 520     getaddress of sCurrentDirectory to lpCurrentDirectory\r
 521     getaddress of sProcessInformation to lpProcessInformation\r
 522     getaddress of sStartupInformation to lpStartupInformation\r
 523     \r
 524     put (length(sStartupInformation)) to sStartupInformation at STARTUPINFO.cb\r
 525     \r
 526     move (CreateProcess(lpApplicationName,lpCommandLine,lpProcessAttributes,lpThreadAttributes,dwCreationFlags,dwCreationFlags,lpEnvironment,lpCurrentDirectory,lpStartupInformation,lpProcessInformation)) to l_iResult\r
 527     \r
 528     getbuff from sProcessInformation at PROCESS_INFORMATION.hProcess to hProcess\r
 529     getbuff from sProcessInformation at PROCESS_INFORMATION.hThread to hThread\r
 530 \r
 531     if (argv3 <> 1) begin\r
 532         if (argv4 = 0) move INFINITE to dwMilliseconds\r
 533         if (argv4 <> 0) move argv4 to dwMilliseconds\r
 534         move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult\r
 535         move (TerminateProcess(hProcess,HEXNULL)) to l_iResult\r
 536         move (CloseHandle(hThread)) to l_iResult\r
 537         move (CloseHandle(hProcess)) to l_iResult\r
 538     end\r
 539     if (argv3 = 1) begin                \r
 540         move hProcess to l_sExit\r
 541         append l_sExit "|" hThread\r
 542     end\r
 543     \r
 544     function_return l_sExit\r
 545 end_function\r
 546 \r
 547 // This will terminate a process started in create_proc with argv3 set to 1\r
 548 // move the string returned by create_proc to argv\r
 549 // set argv2 to 0 if you want to wait for the process to finish before terminating\r
 550 // set argv2 to 1 if you want to terminate the process without waiting for it to finish\r
 551 function term_proc global string argv integer argv2 returns integer\r
 552     local integer l_iSuccess\r
 553     local integer dwMilliseconds l_iResult\r
 554     local handle hProcess hThread\r
 555     \r
 556     move 0 to l_iSuccess\r
 557     move (trim(argv)) to argv\r
 558     if ((argv contains "|") and ((length(argv)) >= 3)) begin    \r
 559         move (left(argv,(pos("|",argv)-1))) to hProcess\r
 560         move (mid(argv,(length(argv)-pos("|",argv)),(pos("|",argv)+1))) to hThread\r
 561         move INFINITE to dwMilliseconds\r
 562         if (argv2 = 0) move (WaitForSingleObject(hProcess,dwMilliseconds)) to l_iResult\r
 563         move (TerminateProcess(hProcess,HEXNULL)) to l_iResult\r
 564         move (CloseHandle(hThread)) to l_iResult\r
 565         move (CloseHandle(hProcess)) to l_iResult\r
 566     end\r
 567     \r
 568     function_return l_iSuccess\r
 569 end_function\r
 570 \r
 571 // Check if a file is locked by a windows process\r
 572 // Returns 1 if the file is locked.\r
 573 function is_locked global string argv returns integer\r
 574     local integer l_iResult l_iDllErr l_iThrow\r
 575     local handle l_hFile    \r
 576     move 0 to l_iResult\r
 577     move -1 to l_hFile\r
 578     move (trim(argv)) to argv   \r
 579     if (argv <> "") begin\r
 580         move (lOpen(argv,(OF_READ+OF_SHARE_EXCLUSIVE))) to l_hFile\r
 581         move (GetLastError()) to l_iDllErr\r
 582         if ((l_hFile = -1) and (l_iDllErr = 32)) move 1 to l_iResult\r
 583         if (l_hFile <> -1) begin\r
 584             move (lClose(l_hFile)) to l_iThrow\r
 585         end\r
 586     end\r
 587     function_return l_iResult\r
 588 end_function\r
 589 \r
 590 // Check if a file exists. Returns 1 if the file exists.\r
 591 function does_exist global string argv returns integer\r
 592     local integer l_iResult l_iDllErr l_iThrow\r
 593     local handle l_hFile    \r
 594     move 0 to l_iResult\r
 595     move -1 to l_hFile\r
 596     move (trim(argv)) to argv   \r
 597     if (argv <> "") begin\r
 598         move 1 to l_iResult\r
 599         move (lOpen(argv,(OF_READ+OF_SHARE_DENY_NONE))) to l_hFile\r
 600         move (GetLastError()) to l_iDllErr\r
 601         if ((l_hFile = -1) and (l_iDllErr = 2)) move 0 to l_iResult\r
 602         if (l_hFile <> -1) begin\r
 603             move (lClose(l_hFile)) to l_iThrow\r
 604         end\r
 605     end\r
 606     function_return l_iResult\r
 607 end_function\r
 608 \r
 609 // Read a text file line by line into the buffer array "Win32API_buffer"\r
 610 // Returns an integer i-1 where i is the count of array elements/lines.\r
 611 //\r
 612 // Ref: http:// msdn2.microsoft.com/en-us/library/aa365467.aspx\r
 613 function buffer_text_file global string argv string argv2 returns integer\r
 614     local string l_sBuf l_sBufL l_structBytesRead l_sLine // String l_structBytesRead used with struct to overcome problem of df not being able to getaddress of integers\r
 615     local handle l_hFileHandle l_hFile\r
 616     local pointer l_pFileName l_pBuf l_pBytesRead\r
 617     local integer l_iFileSize l_iThrow l_iBytesRead l_iBytesToRead l_i l_iDllErr l_iLines\r
 618     \r
 619     send delete_data to Win32API_buffer\r
 620     move -1 to l_iLines\r
 621     \r
 622     move (trim(argv)) to argv\r
 623     move (trim(argv2)) to argv2\r
 624     move -1 to l_hFileHandle\r
 625     move 0 to l_iBytesRead\r
 626     move 1 to l_iBytesToRead\r
 627     move "" to l_sLine\r
 628     \r
 629     if (argv <> "") begin\r
 630         getaddress of argv to l_pFileName\r
 631         move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile\r
 632         move (GetFileSize(l_hFile,0)) to l_iFileSize\r
 633         for l_i from 1 to l_iFileSize\r
 634             // move (SetFilePointer(l_hFile,l_i,0,FILE_CURRENT)) to l_iThrow\r
 635             zerostring 1 to l_sBuf\r
 636             getaddress of l_sBuf to l_pBuf\r
 637             zerotype _STRUCTBYTESREAD to l_structBytesRead\r
 638             getaddress of l_structBytesRead to l_pBytesRead\r
 639             move (ReadFile(l_hFile,l_pBuf,l_iBytesToRead,l_pBytesRead,HexNull)) to l_iThrow\r
 640             getbuff from l_structBytesRead at STRUCTBYTESREAD.integer0 to l_iBytesRead\r
 641             if ((ascii(l_sBuf) = 10) or (ascii(l_sBuf) = 13) or ((argv2 <> "") and (argv2 = l_sBuf))) begin\r
 642                 if (ascii(l_sBufL) <> 13) begin\r
 643                     increment l_iLines\r
 644                     set array_value of (Win32API_buffer(current_object)) item l_iLines to l_sLine\r
 645                     move "" to l_sLine\r
 646                 end\r
 647                 \r
 648             end\r
 649             if ((ascii(l_sBuf) <> 10) and (ascii(l_sBuf) <> 13) and ((argv2 = "") or (argv2 <> l_sBuf))) append l_sLine l_sBuf\r
 650             move l_sBuf to l_sBufL\r
 651         end \r
 652         move (CloseHandle(l_hFile)) to l_iThrow\r
 653     end\r
 654     function_return l_iLines\r
 655 end_function\r
 656 \r
 657 // Return file size in bytes from win32\r
 658 function file_size_bytes global string argv returns integer\r
 659     local integer l_iFileSize l_iThrow\r
 660     local pointer l_pFileName\r
 661     local handle l_hFile\r
 662     \r
 663     move -1 to l_iFileSize\r
 664     \r
 665     if (argv <> "") begin\r
 666         getaddress of argv to l_pFileName\r
 667         move (CreateFile(l_pFileName,GENERIC_READ,FILE_SHARE_READ,HexNull,OPEN_EXISTING,0,HexNull)) to l_hFile\r
 668         move (GetFileSize(l_hFile,0)) to l_iFileSize\r
 669         move (CloseHandle(l_hFile)) to l_iThrow\r
 670     end\r
 671     \r
 672     function_return l_iFileSize\r
 673 end_function\r
 674 \r
 675 // Attempt to convert a string from unicode to ASCII/cp850 via WideCharToMultiByte\r
 676 // http:// msdn2.microsoft.com/en-us/library/ms776420.aspx\r
 677 function to_ascii global string argv returns string\r
 678     local string l_sAscii l_sUnicode\r
 679     local pointer l_pAscii l_pUnicode\r
 680     local integer l_iCharsNeeded l_iThrow\r
 681     move (trim(argv)) to l_sUnicode\r
 682     \r
 683     if (l_sUnicode <> "") begin\r
 684         zerostring (length(l_sUnicode)) to l_sAscii\r
 685         getAddress of l_sAscii to l_pAscii\r
 686         getAddress of l_sUnicode to l_pUnicode\r
 687         \r
 688         // set the length of cchWideChar to -1 and function assumes null termination and calculates length itsself\r
 689         move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,0,0,0,0)) to l_iCharsNeeded              \r
 690         move (WideCharToMultiByte(CP_OEMCP,0,l_pUnicode,-1,l_pAscii,l_iCharsNeeded,0,0)) to l_iThrow\r
 691     end\r
 692     function_return (cstring(l_sAscii))\r
 693 end_function\r
 694 \r
 695 // Attempt to convert a string from ASCII to unicode via MultiByteToWideChar\r
 696 function to_unicode global string argv returns string\r
 697     local string l_sAscii l_sUnicode\r
 698     local pointer l_pAscii l_pUnicode\r
 699     local integer l_iCharsNeeded l_iThrow\r
 700     move (trim(argv)) to l_sAscii\r
 701     \r
 702     if (l_sAscii <> "") begin\r
 703         zerostring (length(l_sAscii)*2) to l_sUnicode\r
 704         getAddress of l_sUnicode to l_pUnicode\r
 705         getAddress of l_sAscii to l_pAscii\r
 706         \r
 707         // set the length of cchWideChar to -1 and function assumes null termination and calculates length itsself\r
 708         move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,0,0,0,0)) to l_iCharsNeeded              \r
 709         move (MultiByteToWideChar(CP_ACP,0,l_pAscii,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow\r
 710     end\r
 711     function_return (cstring(l_sUnicode))  \r
 712 end_function\r
 713 \r
 714 // Attempt to convert a string from ascii to UTF8 via WideCharToMultiByte\r
 715 function to_utf8 global string argv returns string\r
 716     local string l_sUTF8 l_sUnicode\r
 717     local pointer l_pUTF8 l_pUnicode\r
 718     local integer l_iCharsNeeded l_iThrow\r
 719     move (trim(argv)) to l_sUnicode\r
 720     \r
 721     if (l_sUnicode <> "") begin\r
 722         zerostring (length(l_sUnicode)) to l_sUTF8\r
 723         getAddress of l_sUTF8 to l_pUTF8\r
 724         getAddress of l_sUnicode to l_pUnicode\r
 725         \r
 726         // set the length of cchWideChar to -1 and function assumes null termination and calculates lenght itsself\r
 727         move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,0,0,0,0)) to l_iCharsNeeded              \r
 728         move (WideCharToMultiByte(CP_UTF8,0,l_pUTF8,-1,l_pUnicode,l_iCharsNeeded,0,0)) to l_iThrow\r
 729     end\r
 730     \r
 731     function_return (cstring(l_sUTF8))\r
 732 end_function\r
 733 \r
 734 // https://msdn.microsoft.com/en-us/library/windows/desktop/ms647473%28v=vs.85%29.aspx\r
 735 // Note security considerations, as this function doesn't enforce string lengths\r
 736 function ansi_to_oem global string argv returns string\r
 737     local string l_sOem l_sAnsi\r
 738     local pointer l_pOem l_pAnsi\r
 739     local integer l_iResult\r
 740     \r
 741     if (length(argv) <> 0) begin\r
 742         move argv to l_sAnsi\r
 743         getaddress of l_sAnsi to l_pAnsi\r
 744         zerostring (length(l_sAnsi)+1) to l_sOem\r
 745         getaddress of l_sOem to l_pOem\r
 746         move (CharToOem(l_pAnsi, l_pOem)) to l_iResult\r
 747     end\r
 748     else;\r
 749         move argv to l_sOem\r
 750         \r
 751     function_return (cstring(l_sOem))\r
 752 end_function\r
 753 \r
 754 // https://msdn.microsoft.com/en-us/library/windows/desktop/ms647493%28v=vs.85%29.aspx\r
 755 // Note security considerations, as this function doesn't enforce string lengths\r
 756 function oem_to_ansi global string argv returns string\r
 757     local string l_sOem l_sAnsi\r
 758     local pointer l_pOem l_pAnsi\r
 759     local integer l_iResult\r
 760     \r
 761     if (length(argv) <> 0) begin\r
 762         move argv to l_sOem\r
 763         getaddress of l_sOem to l_pOem\r
 764         zerostring (length(l_sOem)+1) to l_sAnsi\r
 765         getaddress of l_sAnsi to l_pAnsi\r
 766         move (CharToOem(l_pOem, l_pAnsi)) to l_iResult\r
 767     end\r
 768     else;\r
 769         move argv to l_sAnsi\r
 770         \r
 771     function_return (cstring(l_sAnsi))\r
 772 end_function\r
 773 \r
 774 // Get running processes on the system\r
 775 // http:// msdn2.microsoft.com/en-us/library/ms682629.aspx\r
 776 // in progress - currently churns out list of process id's to screen\r
 777 function get_procs global integer argv returns integer\r
 778     local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules\r
 779     local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid\r
 780     local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules\r
 781     local handle l_hProcess\r
 782     \r
 783     move (1024*10) to l_iBytes  \r
 784     zerostring l_iBytes to l_sProcesses\r
 785     move 0 to l_iBytesBack\r
 786     \r
 787     getAddress of l_sProcesses to l_pProcesses  \r
 788     zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
 789     getaddress of l_sStructBytesBack to l_pBytesBack\r
 790     \r
 791     move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow\r
 792 \r
 793     getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack\r
 794     \r
 795     if (mod(l_iBytesBack,4) = 0) begin\r
 796         for l_i from 1 to (l_iBytesBack/4)\r
 797             move (left(l_sProcesses,4)) to l_sBuf\r
 798             move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses\r
 799             getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid     \r
 800             move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess\r
 801             \r
 802             move 1024 to l_iBytes2\r
 803             zerostring l_iBytes2 to l_sModules\r
 804             getAddress of l_sModules to l_pModules\r
 805             zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
 806             getaddress of l_sStructBytesBack to l_pBytesBack2\r
 807             \r
 808             move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow\r
 809             getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2\r
 810             \r
 811             // Err here            \r
 812             showln l_i  " PROC=" l_iPid " BYTES=" l_iBytesBack2 " H=" l_hProcess " LERR=" (GetLastError())\r
 813             \r
 814             // showln l_iBytesBack2 " " l_hProcess\r
 815             if (mod(l_iBytesBack2,4) = 0) begin\r
 816                 for l_j from 1 to (l_iBytesBack2/4)\r
 817                     move (left(l_sModules,4)) to l_sBuf\r
 818                     move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules\r
 819                     getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid\r
 820 \r
 821                 loop\r
 822             end\r
 823             move (CloseHandle(l_hProcess)) to l_iThrow\r
 824             \r
 825         loop\r
 826     end\r
 827         \r
 828     showln l_iThrow\r
 829     showln "BYTES " l_iBytesBack\r
 830     \r
 831     function_return 0\r
 832 end_function\r
 833 \r
 834 // Returns the current system time via the GetSystemTime call\r
 835 // Takes an integer value; \r
 836 //     1 - displays individual segments comma separated\r
 837 //     0 - displays a formatted date time\r
 838 function time_data global integer argv returns string\r
 839     local string sTimeData sResult sFormattedTime sFormattedDate\r
 840     local pointer pTimeData pFormattedTime pFormattedDate\r
 841     local integer iThrow iYear iMonth iDayOfWeek iDay iHour iMinute iSecond iMilliSeconds iLenCcTime iLenCcDate iDataLength\r
 842     \r
 843     zeroType _SYSTEMTIME to sTimeData\r
 844     getAddress of sTimeData to pTimeData\r
 845     move (GetSystemTime(pTimeData)) to iThrow\r
 846     \r
 847     // just return the structure comma separated\r
 848     if (argv = 1) begin\r
 849         getBuff from sTimeData at SYSTEMTIME.wYear to iYear\r
 850         getBuff from sTimeData at SYSTEMTIME.wMonth to iMonth\r
 851         getBuff from sTimeData at SYSTEMTIME.wDayOfWeek to iDayOfWeek\r
 852         getBuff from sTimeData at SYSTEMTIME.wDay to iDay\r
 853         getBuff from sTimeData at SYSTEMTIME.wHour to iHour\r
 854         getBuff from sTimeData at SYSTEMTIME.wMinute to iMinute\r
 855         getBuff from sTimeData at SYSTEMTIME.wSecond to iSecond\r
 856         getBuff from sTimeData at SYSTEMTIME.wMilliSeconds to iMilliSeconds\r
 857         \r
 858         move "" to sResult\r
 859         append sResult iYear "," iMonth "," iDay "," iHour "," iMinute "," iSecond "," iMilliSeconds\r
 860     end \r
 861     // give formatted date_time\r
 862     if (argv = 0) begin \r
 863         zerostring 255 to sFormattedTime\r
 864         getaddress of sFormattedTime to pFormattedTime\r
 865         move (length(sFormattedTime)) to iLenCcTime\r
 866     \r
 867         move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedTime, iLenCcTime)) to iDataLength\r
 868 \r
 869         zerostring 255 To sFormattedDate\r
 870         getaddress of sFormattedDate To pFormattedDate\r
 871         move (length(sFormattedDate)) to iLenCcDate\r
 872     \r
 873         move (GetDateFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedDate, iLenCcDate)) to iDataLength\r
 874         move (cstring(sFormattedDate)) to sResult\r
 875         append sResult " " (cstring(sFormattedTime)) // terminating null char removed    \r
 876     end\r
 877     function_return sResult\r
 878 end_function\r
 879 \r
 880 // Insert zeros into the correct places to make a field x wide (similar to zeropad)\r
 881 function fill_0 global integer iValue integer iSize returns string\r
 882     local string sReturn\r
 883 \r
 884     move iValue to sReturn\r
 885     while (length(sReturn) < iSize)\r
 886         insert '0' in sReturn at 1\r
 887     end\r
 888 \r
 889     function_return sReturn\r
 890 end_function\r
 891 \r
 892 // Checks the runtime date format and if it's not adding on the epoch add it\r
 893 function check_date_error global string sDate returns date\r
 894     local integer iDate iY1k\r
 895     local Date    dDate\r
 896 \r
 897     move sDate to iDate\r
 898     move 693975 to iY1k\r
 899 \r
 900     if (iDate < iY1k) Calc (iDate + iY1k) to iDate\r
 901     move iDate to dDate\r
 902 \r
 903     function_return dDate\r
 904 end_function\r
 905 \r
 906 // Get the mod time of a file\r
 907 // This is the core of the replacement / leap year fix of GET_FILE_MOD_TIME\r
 908 // Usage:\r
 909 // get_time(<file>, <mode>)\r
 910 //     1 = created time\r
 911 //     2 = accessed time\r
 912 //     3 = modified time\r
 913 // \r
 914 function get_time global string sFileName integer iMode returns string\r
 915     local string  sCreated sLastAccess sLastChanged sSystemTime sLocalTime sDate sTime sDateSep\r
 916     Local pointer pCreated pLastAccess pLastChanged pSystemTime pLocalTime pFileName\r
 917     Local handle  hCheckFile\r
 918     Local integer iResult iVal iDateSep iDateFormat iDate4State\r
 919 \r
 920     move "" to sTime\r
 921     move "" to sDate\r
 922     \r
 923     getaddress of sFileName to pFileName\r
 924     move (CreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING , 0, 0)) to hCheckFile\r
 925     \r
 926     if (hCheckFile <> INVALID_HANDLE_VALUE) begin\r
 927         zerotype _FILETIME to sCreated\r
 928         zerotype _FILETIME to sLastAccess\r
 929         zerotype _FILETIME to sLastChanged\r
 930         zerotype _FILETIME to sLocalTime\r
 931         getAddress of sCreated to pCreated\r
 932         getAddress of sLastAccess to pLastAccess\r
 933         getAddress of sLastChanged to pLastChanged\r
 934         getAddress of sLocalTime to pLocalTime\r
 935 \r
 936         move (GetFileTime (hCheckFile, pCreated, pLastAccess, pLastChanged)) to iResult \r
 937           \r
 938         if (iResult) begin\r
 939             if (iMode = 1) move (FileTimeToLocalFileTime(pCreated,pLocalTime)) to iResult\r
 940             else if (iMode = 2) move (FileTimeToLocalFileTime(pLastAccess,  pLocalTime)) to iResult\r
 941             else if (iMode = 3) move (FileTimeToLocalFileTime(pLastChanged, pLocalTime)) to iResult\r
 942             \r
 943             zerotype _SYSTEMTIME2 to sSystemTime\r
 944             getAddress of sSystemTime to pSystemTime\r
 945 \r
 946             move (FileTimeToSystemTime(pLocalTime, pSystemTime)) to iResult\r
 947 \r
 948             get_attribute DF_DATE_SEPARATOR to iDateSep\r
 949             move (character(iDateSep))   to sDateSep\r
 950             get_attribute DF_DATE_FORMAT to iDateFormat\r
 951 \r
 952             if (iDateFormat = DF_DATE_USA) begin\r
 953                 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
 954                 append sDate (fill_0(iVal,2))\r
 955                 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
 956                 append sDate sDateSep (fill_0(iVal,2))\r
 957                 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
 958                 append sDate sDateSep (fill_0(iVal,4))\r
 959             end\r
 960             else if iDateFormat eq DF_DATE_EUROPEAN begin\r
 961                 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
 962                 append sDate (fill_0(iVal,2))\r
 963                 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
 964                 append sDate sDateSep (fill_0(iVal,2))\r
 965                 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
 966                 append sDate sDateSep (fill_0(iVal,4))\r
 967             end\r
 968             else if iDateFormat eq DF_DATE_MILITARY begin\r
 969                 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
 970                 append sDate (fill_0(iVal,4))\r
 971                 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
 972                 append sDate sDateSep (fill_0(iVal,2))\r
 973                 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
 974                 append sDate sDateSep (fill_0(iVal,2))\r
 975             end\r
 976 \r
 977             getbuff from sSystemTime at SYSTEMTIME2.wHour to iVal\r
 978             append sTime (fill_0(iVal,2))\r
 979             getbuff from sSystemTime at SYSTEMTIME2.wMinute to iVal\r
 980             append sTime ":" (fill_0(iVal,2))\r
 981             getbuff from sSystemTime at SYSTEMTIME2.wSecond to iVal\r
 982             append sTime ":" (fill_0(iVal,2))\r
 983 \r
 984             append sDate sTime\r
 985         end\r
 986         move (CloseHandle (hCheckFile)) to iResult\r
 987     end\r
 988 \r
 989     function_return sDate\r
 990 end_function\r
 991 \r
 992 // Create a guid GUID (Microsoft)\r
 993 function create_guid global returns string        \r
 994     local integer l_iThrow\r
 995     local pointer l_ptGUID l_ptGUIDString\r
 996     local string l_stGUID l_stGUIDString l_sResult\r
 997    \r
 998     zerotype _GUID to l_stGUID\r
 999     getaddress of l_stGUID to l_ptGUID\r
1000 \r
1001     zerostring GUID_STRING_LENGTH to l_stGUIDString\r
1002     getaddress of l_stGUIDString to l_ptGUIDString\r
1003     \r
1004     if (CoCreateGuid(l_ptGUID) = 0) begin\r
1005         // If successfully created put it in a string\r
1006         move (StringFromGUID2(l_ptGUID, l_ptGUIDString, GUID_STRING_LENGTH)) to l_iThrow\r
1007         move (cstring(to_ascii(l_stGUIDString))) to l_sResult\r
1008     end\r
1009     \r
1010     function_return l_sResult\r
1011 end_function\r
1012 \r
1013 // Get textual description of a win32 error returned by GetLastError()\r
1014 function get_last_error_detail global integer iError returns string\r
1015     local integer l_iThrow\r
1016     local string l_sBuf \r
1017     local pointer l_pBuf\r
1018     \r
1019     zerostring 200 to l_sBuf\r
1020     getaddress of l_sBuf to l_pBuf\r
1021     \r
1022     move (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, iError, LANG_NEUTRAL, l_pBuf, 200, 0)) to l_iThrow\r
1023     \r
1024     function_return (string(iError)+": "+l_sBuf)\r
1025 end_function\r
1026 \r
1027 // Get system disk info\r
1028 // argv1 = disk mount point i.e. c:\\r
1029 // argv2 = "" or "TOTAL", where TOTAL returns free and blank displays used.\r
1030 function disk_info global string argv string argv2 returns number\r
1031     local string l_sSectorsPerCluster l_sBytesPerSector l_sNumberOfFreeClusters l_sTotalNumberOfClusters\r
1032     local pointer l_pSectorsPerCluster l_pBytesPerSector l_pNumberOfFreeClusters l_pTotalNumberOfClusters\r
1033     local number l_iSectorsPerCluster l_iBytesPerSector l_iNumberOfFreeClusters l_iTotalNumberOfClusters l_iSpace\r
1034     \r
1035     move 0 to l_iSpace\r
1036 \r
1037     if (argv <> "") begin\r
1038         zerotype _DISKDATA1 to l_sSectorsPerCluster\r
1039         zerotype _DISKDATA2 to l_sBytesPerSector \r
1040         zerotype _DISKDATA3 to l_sNumberOfFreeClusters \r
1041         zerotype _DISKDATA4 to l_sTotalNumberOfClusters\r
1042 \r
1043         getaddress of l_sSectorsPerCluster to l_pSectorsPerCluster\r
1044         getaddress of l_sBytesPerSector to l_pBytesPerSector\r
1045         getaddress of l_sNumberOfFreeClusters to l_pNumberOfFreeClusters\r
1046         getaddress of l_sTotalNumberOfClusters to l_pTotalNumberOfClusters\r
1047 \r
1048         showln (GetDiskFreeSpace(argv, l_pSectorsPerCluster, l_pBytesPerSector, l_pNumberOfFreeClusters, l_pTotalNumberOfClusters))\r
1049 \r
1050         getbuff from l_sSectorsPerCluster at DISKDATA1.sectorsPerCluster to l_iSectorsPerCluster\r
1051         getbuff from l_sBytesPerSector at DISKDATA2.bytesPerSector to l_iBytesPerSector\r
1052         getbuff from l_sNumberOfFreeClusters at DISKDATA3.numberOfFreeClusters to l_iNumberOfFreeClusters\r
1053         getbuff from l_sTotalNumberOfClusters at DISKDATA4.totalNumberOfClusters to l_iTotalNumberOfClusters\r
1054 \r
1055         // showln l_iSectorsPerCluster\r
1056         // showln l_iBytesPerSector \r
1057         // showln l_iNumberOfFreeClusters\r
1058         // showln l_iTotalNumberOfClusters\r
1059         \r
1060         if (argv2 = "TOTAL") calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iTotalNumberOfClusters) to l_iSpace\r
1061         else calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iNumberOfFreeClusters) to l_iSpace\r
1062     end\r
1063     \r
1064     function_return l_iSpace\r
1065 end_function\r
1066 \r
1067 // Get system memory usage\r
1068 function get_mem_usage global returns integer\r
1069     local integer l_iThrow l_iPid l_iMem\r
1070     local string l_sProcessMemoryCounters\r
1071     local pointer l_lpProcessMemoryCounters\r
1072     local handle l_hProcess\r
1073 \r
1074     zeroType _PROCESS_MEMORY_COUNTERS to l_sProcessMemoryCounters\r
1075     getaddress of l_sProcessMemoryCounters to l_lpProcessMemoryCounters\r
1076 \r
1077     put (length(l_sProcessMemoryCounters)) to l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.cb\r
1078 \r
1079     move (get_process_id(0)) to l_iPid\r
1080     move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess\r
1081 \r
1082     move (GetProcessMemoryInfo(l_hProcess, l_lpProcessMemoryCounters, length(l_sProcessMemoryCounters))) to l_iThrow\r
1083     getbuff from l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.WorkingSetSize to l_iMem\r
1084     \r
1085     // showln l_hProcess " " l_iThrow\r
1086     // showln (GetLastError())\r
1087     // showln (get_last_error_detail(GetLastError()))\r
1088 \r
1089     function_return l_iMem\r
1090 end_function\r
1091 \r
1092 // Uses Microsofts InternetCanonicalizeUrl functionality\r
1093 // http:// msdn.microsoft.com/en-us/library/windows/desktop/aa384342%28v=vs.85%29.aspx\r
1094 // https:// groups.google.com/forum/#!topic/microsoft.public.vb.winapi/0RY8jPsx_14\r
1095 function urldecode global string argv returns string\r
1096     local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult\r
1097     local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength \r
1098     local integer l_iwBufferLength l_iResult l_iDllErr\r
1099 \r
1100     move argv to l_szUrl\r
1101     move argv to l_sResult\r
1102     \r
1103     if (length(l_szUrl) > 0) begin\r
1104         zerostring ((length(l_szUrl))+1) to l_szBuffer\r
1105         getaddress of l_szUrl to l_lpszUrl\r
1106         getaddress of l_szBuffer to l_lpszBuffer\r
1107         \r
1108         zerotype _STRUCTBYTESREAD to l_szStructBytesRead\r
1109         put ((length(l_szBuffer))*4) to l_szStructBytesRead at STRUCTBYTESREAD.integer0   // allow 4 bytes per char to generously allow for any length changes (should be 2)\r
1110         getaddress of l_szStructBytesRead to l_lpdwBufferLength\r
1111 \r
1112         move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_NO_ENCODE+ICU_DECODE)) to l_iResult\r
1113 \r
1114         getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
1115 \r
1116         if (l_iResult <> 1) begin\r
1117             move (GetLastError()) to l_iDllErr\r
1118             custom_error ERROR_CODE_URLDECODE$ ERROR_MSG_URLDECODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))\r
1119         end\r
1120         move (cstring(l_szBuffer)) to l_sResult     \r
1121     end        \r
1122     function_return l_sResult        \r
1123 end_function\r
1124 \r
1125 // Uses Microsofts InternetCanonicalizeUrl functionality\r
1126 // Only encodes parts before ? and #\r
1127 function urlencode global string argv returns string\r
1128     local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult\r
1129     local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength \r
1130     local integer l_iwBufferLength l_iResult l_iDllErr\r
1131 \r
1132     move argv to l_szUrl\r
1133     move argv to l_sResult\r
1134     if (length(l_szUrl) > 0) begin\r
1135         zerostring ((length(l_szUrl))+1) to l_szBuffer\r
1136         getaddress of l_szUrl to l_lpszUrl\r
1137         getaddress of l_szBuffer to l_lpszBuffer\r
1138         \r
1139         zerotype _STRUCTBYTESREAD to l_szStructBytesRead\r
1140         put ((length(l_szBuffer))*4) to l_szStructBytesRead at STRUCTBYTESREAD.integer0   // allow 4 bytes per char to generously allow for any length changes (should be 2)\r
1141         getaddress of l_szStructBytesRead to l_lpdwBufferLength\r
1142 \r
1143         move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_BROWSER_MODE)) to l_iResult\r
1144 \r
1145         getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
1146 \r
1147         if (l_iResult <> 1) begin\r
1148             move (GetLastError()) to l_iDllErr\r
1149             custom_error ERROR_CODE_URLENCODE$ ERROR_MSG_URLENCODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))\r
1150         end\r
1151         move (cstring(l_szBuffer)) to l_sResult     \r
1152     end        \r
1153     function_return l_sResult        \r
1154 end_function\r
1155 \r
1156 // Functions to pull windows os version string\r
1157 function get_os_version global returns string\r
1158     local string l_sOsInfo l_sVersion l_sReturn\r
1159     local pointer l_pOsInfo\r
1160     local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform\r
1161     \r
1162     move "" to l_sVersion\r
1163     \r
1164     zerotype _OSVERSIONINFO to  l_sOsInfo\r
1165     put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize\r
1166     getaddress of l_sOsInfo to  l_pOsInfo\r
1167     \r
1168     move (GetVersionEx(l_pOsInfo)) to l_iResult\r
1169     \r
1170     if (l_iResult = 1) begin\r
1171         getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor\r
1172         getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor\r
1173         getbuff from l_sOsInfo at OSVERSIONINFO.dwBuildNumber to l_iBuild\r
1174         getbuff from l_sOsInfo at OSVERSIONINFO.dwPlatformId to l_iPlatform\r
1175         // getbuff from l_sOsInfo at OSVERSIONINFO.szCSDVersion to l_sVersion    !??\r
1176         move (cstring(right(l_sOsInfo,128))) to l_sVersion\r
1177     end\r
1178     \r
1179     move ("Windows Version: "+string(l_iMajor)+"."+string(l_iMinor)+" Build: "+string(l_iBuild)+" Platform: "+string(l_iPlatform)+" CSDVersion: "+l_sVersion) to l_sReturn\r
1180     \r
1181     function_return l_sReturn \r
1182 end_function\r
1183 \r
1184 // Functions to pull windows os version as a numeric value\r
1185 function get_os_version_numeric global returns number\r
1186     local string l_sOsInfo l_sVersion\r
1187     local pointer l_pOsInfo\r
1188     local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform\r
1189     \r
1190     move "" to l_sVersion\r
1191     \r
1192     zerotype _OSVERSIONINFO to  l_sOsInfo\r
1193     put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize\r
1194     getaddress of l_sOsInfo to  l_pOsInfo\r
1195     \r
1196     move (GetVersionEx(l_pOsInfo)) to l_iResult\r
1197     \r
1198     if (l_iResult = 1) begin\r
1199         getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor\r
1200         getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor\r
1201     end\r
1202     \r
1203     function_return (number(l_iMajor)+(number(l_iMinor)/10))\r
1204 end_function\r
1205 \r
1206 // Converts binary to hex or base64 strings and vice versa\r
1207 function binary_to_string_to_binary global string argv string argv2 string argv3 returns string\r
1208     local string l_sData l_sDataDecoded l_sDataSizeDecoded l_sReturn\r
1209     local pointer l_pData l_pDataDecoded l_pDataSizeDecoded\r
1210     local integer l_iResult l_iDataSize l_iDataSizeDecoded l_iOffset\r
1211     \r
1212     move argv to l_sData\r
1213     move (length(l_sData)) to l_iDataSize\r
1214     getaddress of l_sData to l_pData\r
1215      \r
1216     zerostring ((length(l_sData)*4)+1) to l_sDataDecoded\r
1217     getaddress of l_sDataDecoded to l_pDataDecoded\r
1218             \r
1219     zerotype _DW_TYPE to l_sDataSizeDecoded\r
1220     put (length(l_sDataDecoded)) to l_sDataSizeDecoded at DW_TYPE.value\r
1221     getaddress of l_sDataSizeDecoded to l_pDataSizeDecoded      \r
1222     \r
1223     case begin\r
1224         case (argv2 = "HEX") begin\r
1225             if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult\r
1226             if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult\r
1227         end\r
1228         case break\r
1229         case (argv2 = "BASE64") begin\r
1230             if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult\r
1231             if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult\r
1232         end\r
1233         case break\r
1234         case else custom_error ERROR_CODE_UNKNOWN_FORMAT$ ERROR_MSG_UNKNOWN_FORMAT argv2\r
1235     case end\r
1236 \r
1237     getbuff from l_sDataSizeDecoded at DW_TYPE.value to l_iDataSizeDecoded\r
1238 \r
1239     if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1240         showln "ERROR: " (ternary(argv3 = 0, "CryptBinaryToString", "CryptStringToBinary")) " "  l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1241         showln "DATA = " l_sDataDecoded\r
1242         showln "SIZE = " l_iDataSizeDecoded\r
1243     end\r
1244     else begin\r
1245         if (argv3 = 0) move (replaces(character(9),replaces(character(10),replaces(character(13),replaces(character(32),cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset)),""),""),""),"")) to l_sReturn              \r
1246         else move (cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset))) to l_sReturn\r
1247     end\r
1248     \r
1249     function_return l_sReturn\r
1250 end_function\r
1251 \r
1252 // Convert binary data to hex or base64 \r
1253 function binary_to_string global string argv string argv2 returns string\r
1254     function_return (binary_to_string_to_binary(argv, argv2, 0))\r
1255 end_function\r
1256 // Convert hex or base64 strings to binary data\r
1257 function string_to_binary global string argv string argv2 returns string\r
1258     function_return (binary_to_string_to_binary(argv, argv2, 1))\r
1259 end_function\r
1260 \r
1261 // List out cryptographic providers on ms windows\r
1262 function ms_adv_listproviders global returns integer\r
1263     local integer l_i l_iResult l_iType\r
1264     local string l_sType l_sName l_sNameSize\r
1265     local pointer l_pType l_pName l_pNameSize\r
1266 \r
1267     move -1 to l_i\r
1268     repeat\r
1269         increment l_i\r
1270         \r
1271         zerotype _DW_TYPE to l_sType\r
1272         getaddress of l_sType to l_pType\r
1273         \r
1274         zerostring 255 to l_sName\r
1275         getaddress of l_sName to l_pName\r
1276         \r
1277         zerotype _DW_TYPE to l_sNameSize\r
1278         put length(l_sName) to l_sNameSize at DW_TYPE.value\r
1279         getaddress of l_sNameSize to l_pNameSize\r
1280     \r
1281         move (CryptEnumProviders(l_i, HEXNULL, 0, l_pType, l_pName, l_pNameSize)) to l_iResult\r
1282 \r
1283         if ((l_iResult <> 1) and (GetLastError() <> 0) and (GetLastError() <> 259)) begin\r
1284             showln "ERROR: " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1285         end\r
1286         getbuff from l_sType at DW_TYPE.value to l_iType\r
1287         \r
1288         if (l_iResult = 1) showln l_i ") " l_iType " - '" (cstring(l_sName)) "'"\r
1289     until (l_iResult <> 1)\r
1290 \r
1291 end_function\r
1292 \r
1293 //-------------------------------------------------------------------------\r
1294 // Classes\r
1295 //-------------------------------------------------------------------------\r
1296 \r
1297 // Object to provide basic implimentations of some popular hash algorithms and encryption\r
1298 // provided by the Microsoft Cryptographic Provider\r
1299 //\r
1300 // Send message methods:\r
1301 //\r
1302 //    aquire_context                - Create the context of the Microsoft CSP\r
1303 //    release_context               - Release the context of the Microsoft CSP\r
1304 //    import_key <key> <ealg>       - Incomplete/WIP\r
1305 //    derive_key <psw> <halg> <ealg>- Derives an encryption key provider when supplied\r
1306 //                                    with a password, a hash algorithm and the required \r
1307 //                                    encryption.\r
1308 //    modify_key_iv <iv>            - Set the initilization vector of the key provider\r
1309 //    modify_key_mode <mode>        - Set the key provider mode E.g. CBC, ECB etc\r
1310 //    destroy_key                   - Dispose of the current key provider\r
1311 //\r
1312 // Get methods:\r
1313 //    hash_data <data> <halg>       - Returns a hash of the passed data in the specified \r
1314 //                                    algorithm\r
1315 //    export_key                    - Returns the current encryption key\r
1316 //    generate_random_key_iv        - Generates and sets a random initilization vector \r
1317 //                                    for the key provider\r
1318 //    encrypt <data>                - Encrypt data\r
1319 //    decrypt <data>                - Decrypt data\r
1320 //\r
1321 // Example usage:\r
1322 //    \r
1323 //    object test is an msAdvCrypt\r
1324 //    end_object\r
1325 //    string data buf\r
1326 //    \r
1327 //    // Generate a hash\r
1328 //    send aquire_context to test\r
1329 //    get hash_data of test "MYTEXT" "SHA1" to data\r
1330 //    send release_context to test\r
1331 //    showln "HASHED: " (binary_to_string(data,"HEX"))\r
1332 //    \r
1333 //    // Encrypt some data\r
1334 //    send aquire_context to test\r
1335 //    send derive_key to test "MYPASSWORD" "SHA256" "AES_256"\r
1336 //    send modify_key_mode to test "CBC"\r
1337 //    get generate_random_key_iv of test to buf\r
1338 //    move buf to data\r
1339 //    get encrypt of test "MYDATA" to buf\r
1340 //    append data buf\r
1341 //    send destroy_key to test\r
1342 //    send release_context to test\r
1343 //    showln "ENCRYPTED: " (binary_to_string(data,"HEX"))\r
1344 //    \r
1345 //    // Decrypt some data\r
1346 //    send aquire_context to test\r
1347 //    send derive_key to test "MYPASSWORD" "SHA256" "AES_256"\r
1348 //    send modify_key_mode to test "CBC"\r
1349 //    send modify_key_iv to test (mid(data,16,1))\r
1350 //    get decrypt of test (mid(data,length(data)-16,17)) to data\r
1351 //    send destroy_key to test\r
1352 //    send release_context to test\r
1353 //    showln "DECRYPTED: " data\r
1354 //    \r
1355 class msAdvCrypt is an array\r
1356     procedure construct_object string argc \r
1357         forward send construct_object argc\r
1358         \r
1359         property handle c_hProv \r
1360         property handle c_hHash \r
1361         property handle c_hKey\r
1362         property string c_sAlg\r
1363     end_procedure\r
1364 \r
1365     procedure aquire_context\r
1366         local integer l_iResult\r
1367         local handle l_hProv\r
1368         local string l_shProv\r
1369         local pointer l_phProv\r
1370         \r
1371         zerotype _DW_TYPE to l_shProv\r
1372         getaddress of l_shProv to l_phProv\r
1373         \r
1374         if (get_os_version_numeric() < 5.2) begin\r
1375             move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult\r
1376             if (GetLastError() = -2146893802) begin\r
1377                 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult\r
1378             end\r
1379         end\r
1380         else begin\r
1381             move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult\r
1382             if (GetLastError() = -2146893802) begin\r
1383                 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult\r
1384             end\r
1385         end\r
1386         \r
1387         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1388             showln "ERROR: CryptAcquireContext " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1389         end\r
1390         else begin\r
1391             getbuff from l_shProv at DW_TYPE.value to l_hProv\r
1392             set c_hProv to l_hProv\r
1393         end        \r
1394     end_procedure\r
1395     \r
1396     function make_hash string in_data string in_hashalgorithm returns string\r
1397         local integer l_iResult l_iHashSize\r
1398         local string l_shHash l_sHash l_sRawString l_sHashSize\r
1399         local handle l_hProv l_hHash\r
1400         local pointer l_phHash l_pHash l_pRawString l_pHashSize\r
1401         \r
1402         get c_hProv to l_hProv\r
1403         \r
1404         if (l_hProv = 0) begin\r
1405             custom_error ERROR_CODE_NO_CONTEXT$ ERROR_MSG_NO_CONTEXT\r
1406         end\r
1407         else begin\r
1408             move in_data to l_sRawString\r
1409             getaddress of l_sRawString to l_pRawString\r
1410             \r
1411             zerotype _HCRYPTHASH to l_shHash\r
1412             getaddress of l_shHash to l_phHash        \r
1413     \r
1414             case begin\r
1415                 case (in_hashalgorithm = "MD5") begin\r
1416                     move (CryptCreateHash(l_hProv, CALG_MD5, 0, 0, l_phHash)) to l_iResult\r
1417                     zerostring (128/8) to l_sHash\r
1418                 end\r
1419                 case break  \r
1420                 case ((in_hashalgorithm = "SHA1") or (in_HASHalgorithm = "SHA")) begin\r
1421                     move (CryptCreateHash(l_hProv, CALG_SHA1, 0, 0, l_phHash)) to l_iResult\r
1422                     zerostring (160/8) to l_sHash\r
1423                 end\r
1424                 case break\r
1425                 case (in_hashalgorithm = "SHA256") begin\r
1426                     move (CryptCreateHash(l_hProv, CALG_SHA_256, 0, 0, l_phHash)) to l_iResult\r
1427                     zerostring (256/8) to l_sHash           \r
1428                 end\r
1429                 case break\r
1430                 case (in_hashalgorithm = "SHA384") begin\r
1431                     move (CryptCreateHash(l_hProv, CALG_SHA_384, 0, 0, l_phHash)) to l_iResult\r
1432                     zerostring (384/8) to l_sHash           \r
1433                 end\r
1434                 case break\r
1435                 case (in_hashalgorithm = "SHA512") begin\r
1436                     move (CryptCreateHash(l_hProv, CALG_SHA_512, 0, 0, l_phHash)) to l_iResult\r
1437                     zerostring (512/8) to l_sHash                    \r
1438                 end\r
1439                 case break  \r
1440                 case else begin\r
1441                     custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_hashalgorithm\r
1442                 end\r
1443             case end        \r
1444         \r
1445             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1446                 showln "ERROR: CryptCreateHash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1447             end\r
1448         \r
1449             getbuff from l_shHash at HCRYPTHASH.value to l_hHash\r
1450             getaddress of l_sHash to l_pHash\r
1451         \r
1452             move (CryptHashData(l_hHash, l_pRawString, (length(l_sRawString)), 0)) to l_iResult\r
1453         \r
1454             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1455                 showln "ERROR: Crypthash_data " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1456             end\r
1457         \r
1458             zerotype _DW_TYPE to l_sHashSize\r
1459             put (length(l_sHash)) to l_sHashSize at DW_TYPE.value\r
1460             getaddress of l_sHashSize to l_pHashSize\r
1461     \r
1462             move (CryptGetHashParam(l_hHash, HP_HASHVAL, l_pHash, l_pHashSize, 0)) to l_iResult\r
1463         \r
1464             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1465                 showln "ERROR: CryptGetHashParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1466             end    \r
1467         \r
1468             getbuff from l_sHashSize at DW_TYPE.value to l_iHashSize\r
1469 \r
1470             if (l_iHashSize <> length(l_sHash)) begin\r
1471                 showln "WARNING: Binary data does not match expected hash size:"\r
1472                 showln "DATA = " l_sHash\r
1473                 showln "SIZE = " l_iHashSize " / " (length(l_sHash))\r
1474             end        \r
1475         end\r
1476     \r
1477         set c_hHash to l_hHash        \r
1478    \r
1479         function_return (mid(l_sHash,l_iHashSize,1))\r
1480     end_function \r
1481         \r
1482     procedure destroy_hash\r
1483         local integer l_iResult\r
1484         local handle l_hHash\r
1485         \r
1486         get c_hHash to l_hHash\r
1487 \r
1488         if (l_hHash <> 0) begin\r
1489             move (CryptDestroyHash(l_hHash)) to l_iResult\r
1490             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1491                 showln "ERROR: Cryptdestroy_hash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1492             end        \r
1493             else set c_hHash to 0\r
1494         end        \r
1495     end_procedure\r
1496 \r
1497     function hash_data string in_data string in_hashalgorithm returns string\r
1498         local integer l_iResult\r
1499         local string l_sHash\r
1500         \r
1501         get make_hash in_data in_hashalgorithm to l_sHash\r
1502         send destroy_hash\r
1503         \r
1504         function_return (cstring(l_sHash))\r
1505     end_function \r
1506     \r
1507     //WIP\r
1508     procedure import_key string in_key string in_algorithm\r
1509         local integer l_iResult\r
1510         local string l_sBlobHeader l_sPlainTextKeyBlob l_shKey\r
1511         local handle l_hProv l_hKey\r
1512         local pointer l_pPlainTextKeyBlob l_phKey\r
1513         \r
1514         get c_hProv to l_hProv   \r
1515         \r
1516         zerotype _BLOBHEADER to l_sBlobHeader \r
1517         put PLAINTEXTKEYBLOB to l_sBlobHeader at BLOBHEADER.bType\r
1518         put 2 to l_sBlobHeader at BLOBHEADER.bVersion\r
1519         put 0 to l_sBlobHeader at BLOBHEADER.Reserved\r
1520         \r
1521         case begin        \r
1522             case (in_algorithm = "DES") put CALG_DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1523             case break \r
1524             case (in_algorithm = "3DES") put CALG_3DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1525             case break \r
1526             case (in_algorithm = "3DES_112") put CALG_3DES_112 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1527             case break \r
1528             case (in_algorithm = "AES") put CALG_AES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1529             case break \r
1530             case (in_algorithm = "AES_128") put CALG_AES_128 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1531             case break \r
1532             case (in_algorithm = "AES_192") put CALG_AES_192 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1533             case break \r
1534             case (in_algorithm = "AES_256") put CALG_AES_256 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1535             case break \r
1536             case (in_algorithm = "RC2") put CALG_RC2 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1537             case break \r
1538             case (in_algorithm = "RC4") put CALG_RC4 to l_sBlobHeader at BLOBHEADER.ALG_ID        \r
1539             case break \r
1540             case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
1541         case end\r
1542         \r
1543         zerotype _PLAINTEXTKEYBLOB to l_sPlainTextKeyBlob\r
1544         put l_sBlobHeader to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.BLOBHEADER\r
1545         put (length(in_key)) to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.dwKeySize\r
1546         put_string in_key to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.rgbKeyData       \r
1547         \r
1548         getaddress of l_sPlainTextKeyBlob to l_pPlainTextKeyBlob\r
1549         \r
1550         zerotype _HCRYPTKEY to l_shKey\r
1551         getaddress of l_shKey to l_phKey\r
1552         \r
1553         move (CryptImportKey(l_hProv, l_pPlainTextKeyBlob, length(l_sPlainTextKeyBlob), 0, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1554         \r
1555         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1556             showln "ERROR: CryptImportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1557         end\r
1558             \r
1559         getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
1560         \r
1561     end_procedure\r
1562     \r
1563     procedure derive_key string in_data string in_hashalgorithm string in_algorithm\r
1564         local integer l_iResult\r
1565         local handle l_hProv l_hHash l_hKey\r
1566         local string l_sKey l_shKey\r
1567         local pointer l_phKey\r
1568         \r
1569         get c_hProv to l_hProv        \r
1570         get make_hash in_data in_hashalgorithm to l_sKey        \r
1571         get c_hHash to l_hHash\r
1572 \r
1573         if (l_hHash <> 0) begin\r
1574             zerotype _HCRYPTKEY to l_shKey\r
1575             getaddress of l_shKey to l_phKey\r
1576 \r
1577             // The default cipher mode to be used depends on the underlying CSP and the algorithm that's being used, but it's generally CBC mode\r
1578             case begin\r
1579                 case (in_algorithm = "DES") move (CryptDeriveKey(l_hProv, CALG_DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1580                 case break \r
1581                 case (in_algorithm = "3DES") move (CryptDeriveKey(l_hProv, CALG_3DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1582                 case break \r
1583                 case (in_algorithm = "3DES_112") move (CryptDeriveKey(l_hProv, CALG_3DES_112, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1584                 case break \r
1585                 case (in_algorithm = "AES") move (CryptDeriveKey(l_hProv, CALG_AES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1586                 case break \r
1587                 case (in_algorithm = "AES_128") move (CryptDeriveKey(l_hProv, CALG_AES_128, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1588                 case break \r
1589                 case (in_algorithm = "AES_192") move (CryptDeriveKey(l_hProv, CALG_AES_192, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1590                 case break \r
1591                 case (in_algorithm = "AES_256") move (CryptDeriveKey(l_hProv, CALG_AES_256, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1592                 case break \r
1593                 case (in_algorithm = "RC2") move (CryptDeriveKey(l_hProv, CALG_RC2, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1594                 case break \r
1595                 case (in_algorithm = "RC4") move (CryptDeriveKey(l_hProv, CALG_RC4, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1596                 case break \r
1597                 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
1598             case end\r
1599             \r
1600             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1601                 showln "ERROR: CryptDeriveKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1602             end\r
1603             else begin        \r
1604                 getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
1605                 set c_sAlg to in_algorithm\r
1606             end\r
1607 \r
1608             set c_hKey to l_hKey\r
1609         end\r
1610     end_procedure\r
1611        \r
1612     procedure modify_key_iv string in_iv\r
1613         local integer l_iResult l_iBlockSize\r
1614         local handle l_hKey\r
1615         local string l_sIV l_sAlg\r
1616         local pointer l_pIV\r
1617         \r
1618         get c_hKey to l_hKey\r
1619         get c_sAlg to l_sAlg\r
1620         \r
1621         // Set expected block size in bytes\r
1622         case begin\r
1623             case (l_sAlg contains "DES") calc (64/8) to l_iBlockSize\r
1624             case break         \r
1625             case (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
1626             case break \r
1627             case (l_sAlg = "RC2") calc (64/8) to l_iBlockSize\r
1628             case break \r
1629             case else custom_error ERROR_CODE_INCOMPATIBLE_ALGORITHM$ ERROR_MSG_INCOMPATIBLE_ALGORITHM l_sAlg\r
1630         case end\r
1631         \r
1632         if (length(in_iv) <> l_iBlockSize) custom_error ERROR_CODE_INVALID_BLOCKSIZE$ ERROR_MSG_INVALID_BLOCKSIZE (l_sAlg+"="+string(l_iBlockSize)+" NOT "+string(length(in_iv)))\r
1633         \r
1634         move in_iv to l_sIV\r
1635         getaddress of l_sIV to l_pIV\r
1636         \r
1637         move (CryptSetKeyParam(l_hKey, KP_IV, l_pIV, 0)) to l_iResult\r
1638         \r
1639         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1640             showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1641         end        \r
1642         \r
1643     end_procedure\r
1644     \r
1645     function generate_random_key_iv returns string\r
1646         local integer l_i l_iBlockSize\r
1647         local string l_sIV l_sAlg        \r
1648      \r
1649         get c_sAlg to l_sAlg\r
1650         move "" to l_sIV\r
1651         \r
1652         if ((l_sAlg contains "DES") or (l_sAlg = "RC2")) calc (64/8) to l_iBlockSize\r
1653     if (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
1654         \r
1655         for l_i from 1 to l_iBlockSize\r
1656             append l_sIV (character(48+random(47)))\r
1657         loop\r
1658         \r
1659         send modify_key_iv l_sIV\r
1660         \r
1661         function_return l_sIV\r
1662     end_function\r
1663     \r
1664     procedure modify_key_mode string in_mode\r
1665         local integer l_iResult\r
1666         local handle l_hKey\r
1667         local string l_sMode l_sbData\r
1668         local pointer l_pbData\r
1669         \r
1670         get c_hKey to l_hKey\r
1671 \r
1672         case begin\r
1673             case (in_mode contains "CBC") move CRYPT_MODE_CBC to l_sMode\r
1674             case break\r
1675             case (in_mode contains "ECB") move CRYPT_MODE_ECB to l_sMode\r
1676             case break\r
1677             case (in_mode contains "OFB") move CRYPT_MODE_OFB to l_sMode\r
1678             case break\r
1679             case (in_mode contains "CFB") move CRYPT_MODE_CFB to l_sMode\r
1680             case break\r
1681             case (in_mode contains "CTS") move CRYPT_MODE_CTS to l_sMode\r
1682             case break            \r
1683             case else custom_error ERROR_CODE_UNRECOGNISED_MODE$ ERROR_MSG_UNRECOGNISED_MODE l_sMode        \r
1684         case end\r
1685         \r
1686         zerotype _DW_TYPE to l_sbData\r
1687         put l_sMode to l_sbData at DW_TYPE.value\r
1688         getaddress of l_sbData to l_pbData       \r
1689         \r
1690         move (CryptSetKeyParam(l_hKey, KP_MODE, l_pbData, 0)) to l_iResult\r
1691         \r
1692         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1693             showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1694         end        \r
1695     \r
1696     end_procedure\r
1697     \r
1698     function export_key returns string\r
1699         local integer l_iResult\r
1700         local string l_sData l_sDataSize\r
1701         local handle l_hKey\r
1702         local pointer l_pData l_pDataSize\r
1703         local integer l_iKeyBlobSize l_iDataSize\r
1704         \r
1705         get c_hKey to l_hKey\r
1706         \r
1707         if (l_hKey <> 0) begin\r
1708             zerotype _PLAINTEXTKEYBLOB to l_sData\r
1709             getaddress of l_sData to l_pData\r
1710         \r
1711             zerotype _DW_TYPE to l_sDataSize\r
1712             put (length(l_sData)) to l_sDataSize at DW_TYPE.value\r
1713             getaddress of l_sDataSize to l_pDataSize\r
1714         \r
1715             move (CryptExportKey(l_hKey, 0, PLAINTEXTKEYBLOB, 0, l_pData, l_pDataSize)) to l_iResult\r
1716             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1717                 showln "ERROR: CryptExportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1718             end \r
1719         \r
1720             getbuff from l_sDataSize at DW_TYPE.value to l_iKeyBlobSize\r
1721             getbuff from l_sData at PLAINTEXTKEYBLOB.dwKeySize to l_iDataSize\r
1722             move (mid(l_sData,l_iDataSize,13)) to l_sData\r
1723             \r
1724             if (show_debug_lines) begin\r
1725                 showln "DEBUG: Key blob Size = " l_iKeyBlobSize        \r
1726             end\r
1727        end\r
1728        function_return l_sData\r
1729     end_function\r
1730     \r
1731     function encrypt_decrypt string in_data integer in_decrypt returns string\r
1732         local integer l_iResult l_iDataSize\r
1733         local string l_sData l_sDataSize\r
1734         local pointer l_pData l_pDataSize \r
1735         local handle l_hKey\r
1736         \r
1737         move in_data to l_sData    \r
1738         get c_hKey to l_hKey\r
1739         \r
1740         zerotype _DW_TYPE to l_sDataSize\r
1741         put (length(l_sData)) to l_sDataSize at DW_TYPE.value\r
1742         getaddress of l_sDataSize to l_pDataSize                        \r
1743         \r
1744         move (l_sData+repeat(' ',length(l_sData)*2)) to l_sData\r
1745         getaddress of l_sData to l_pData        \r
1746         \r
1747         if (in_decrypt = 0) move (CryptEncrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize, length(l_sData))) to l_iResult\r
1748         else move (CryptDecrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize)) to l_iResult             \r
1749 \r
1750         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1751             showln "ERROR: " (ternary(in_decrypt = 0, "CryptEncrypt", "CryptDecrypt")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1752         end\r
1753         \r
1754         getbuff from l_sDataSize at DW_TYPE.value to l_iDataSize\r
1755         move (cstring(mid(l_sData,l_iDataSize,1))) to l_sData\r
1756         \r
1757         function_return l_sData\r
1758     end_function\r
1759     \r
1760     function encrypt string in_data returns string\r
1761         local string l_sData\r
1762         \r
1763         get encrypt_decrypt in_data 0 to l_sData\r
1764         function_return l_sData\r
1765     end_function\r
1766     \r
1767     function decrypt string in_data returns string\r
1768         local string l_sData\r
1769         \r
1770         get encrypt_decrypt in_data 1 to l_sData\r
1771         function_return l_sData\r
1772     end_function\r
1773     \r
1774     procedure destroy_key\r
1775         local integer l_iResult\r
1776         local handle l_hKey l_hHash\r
1777         \r
1778         get c_hKey to l_hKey\r
1779         \r
1780         if (l_hKey <> 0) begin\r
1781             move (CryptDestroyKey(l_hKey)) to l_iResult     \r
1782             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1783                 showln "ERROR: CryptDestroyKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))                      \r
1784             end  \r
1785             else begin\r
1786                 set c_hKey to 0\r
1787                 set c_sAlg to ""\r
1788             end\r
1789         end\r
1790         \r
1791         get c_hHash to l_hHash\r
1792         if (l_hHash <> 0) send destroy_hash        \r
1793         \r
1794     end_procedure\r
1795     \r
1796     procedure release_context\r
1797         local integer l_iResult\r
1798         local handle l_hProv  \r
1799         \r
1800         get c_hProv to l_hProv\r
1801     \r
1802         if (l_hProv <> 0) begin    \r
1803             move (CryptReleaseContext(l_hProv, 0)) to l_iResult\r
1804             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1805                 showln "ERROR: Cryptrelease_context " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1806             end    \r
1807             else set c_hProv to 0\r
1808         end\r
1809         \r
1810     end_procedure\r
1811     \r
1812     procedure destory_object\r
1813         local handle l_hProv l_hHash l_hKey\r
1814         \r
1815         get c_hKey to l_hKey\r
1816         if (l_hKey <> 0) send destroy_key\r
1817         \r
1818         get c_hHash to l_hHash\r
1819         if (l_hHash <> 0) send destroy_hash\r
1820         \r
1821         get c_hProv to l_hProv\r
1822         if (l_hProv <> 0) send release_context\r
1823              \r
1824         forward send destory_object\r
1825     end_procedure\r
1826         \r
1827 end_class\r
1828 \r
1829 //-------------------------------------------------------------------------\r
1830 // Functions\r
1831 //-------------------------------------------------------------------------\r
1832 \r
1833 // Used for procedural invocations of hashing and encrypting\r
1834 object msAdvCrypt_global_obj is an msAdvCrypt\r
1835 end_object\r
1836 \r
1837 // Procedural one-shot use of msAdvCrypt hashing\r
1838 function msAdvCrypt_hash global string in_data string in_hash returns string\r
1839     local string l_sReturn\r
1840    \r
1841     send aquire_context to msAdvCrypt_global_obj\r
1842     get make_hash of msAdvCrypt_global_obj in_data in_hash to l_sReturn\r
1843     send destroy_hash to msAdvCrypt_global_obj\r
1844     send release_context to msAdvCrypt_global_obj\r
1845     \r
1846     function_return l_sReturn\r
1847 end_function\r
1848 \r
1849 function sha512_hex global string in_data returns string\r
1850     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'HEX'))\r
1851 end_function\r
1852 \r
1853 function sha512_base64 global string in_data returns string\r
1854     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'BASE64'))\r
1855 end_function\r
1856 \r
1857 function sha384_hex global string in_data returns string\r
1858     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'HEX'))\r
1859 end_function\r
1860 \r
1861 function sha384_base64 global string in_data returns string\r
1862     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'BASE64'))\r
1863 end_function\r
1864 \r
1865 function sha256_hex global string in_data returns string\r
1866     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'HEX'))\r
1867 end_function\r
1868 \r
1869 function sha256_base64 global string in_data returns string\r
1870     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'BASE64'))\r
1871 end_function\r
1872 \r
1873 function sha1_hex global string in_data returns string\r
1874     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'HEX'))\r
1875 end_function\r
1876 \r
1877 function sha1_base64 global string in_data returns string\r
1878     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'BASE64'))\r
1879 end_function\r
1880 \r
1881 function md5_hex global string in_data returns string\r
1882     function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'HEX'))\r
1883 end_function\r
1884 \r
1885 function md5_base64 global string in_data returns string\r
1886     function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'BASE64'))\r
1887 end_function\r
1888 \r
1889 // Procedural one-shot use of msAdvCrypt AES256 encryption (HEX)\r
1890 function aes256_hex_enc global string in_data string in_key returns string\r
1891     local string l_sReturn l_sBuf\r
1892    \r
1893     send aquire_context to msAdvCrypt_global_obj\r
1894     \r
1895     send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"\r
1896     send modify_key_mode to msAdvCrypt_global_obj "CBC"\r
1897     \r
1898     get generate_random_key_iv of msAdvCrypt_global_obj to l_sBuf    \r
1899     move l_sBuf to l_sReturn\r
1900     \r
1901     get encrypt of msAdvCrypt_global_obj in_data to l_sBuf\r
1902     append l_sReturn l_sBuf\r
1903     \r
1904     send destroy_key to msAdvCrypt_global_obj    \r
1905     send release_context to msAdvCrypt_global_obj\r
1906     \r
1907     function_return (binary_to_string(l_sReturn,"HEX"))\r
1908 end_function\r
1909 \r
1910 // Procedural one-shot use of msAdvCrypt AES256 decryption (HEX)\r
1911 function aes256_hex_dec global string in_data string in_key returns string\r
1912     local string l_sReturn l_sBuf\r
1913    \r
1914     move (string_to_binary(in_data,"HEX")) to l_sBuf\r
1915    \r
1916     send aquire_context to msAdvCrypt_global_obj    \r
1917     send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"\r
1918     send modify_key_mode to msAdvCrypt_global_obj "CBC"\r
1919     \r
1920     send modify_key_iv to msAdvCrypt_global_obj (mid(l_sBuf,16,1))\r
1921     \r
1922     get decrypt of msAdvCrypt_global_obj (mid(l_sBuf,length(l_sBuf)-16,17)) to l_sReturn\r
1923     \r
1924     send destroy_key to msAdvCrypt_global_obj    \r
1925     send release_context to msAdvCrypt_global_obj\r
1926     \r
1927     function_return l_sReturn\r
1928 end_function\r