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-2009, 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 100 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 lenght 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 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 100 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 lenght 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 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 100 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 l_sUTF8\r
 732 end_function\r
 733 \r
 734 // Get running processes on the system\r
 735 // http:// msdn2.microsoft.com/en-us/library/ms682629.aspx\r
 736 // in progress - currently churns out list of process id's to screen\r
 737 function get_procs global integer argv returns integer\r
 738     local string l_sProcesses l_sStructBytesBack l_sBuf l_sModules\r
 739     local integer l_iThrow l_iBytes l_iBytes2 l_iBytesBack l_iBytesBack2 l_i l_j l_iPid l_iMid\r
 740     local pointer l_pProcesses l_pBytesBack l_pBytesBack2 l_pModules\r
 741     local handle l_hProcess\r
 742     \r
 743     move (1024*10) to l_iBytes  \r
 744     zerostring l_iBytes to l_sProcesses\r
 745     move 0 to l_iBytesBack\r
 746     \r
 747     getAddress of l_sProcesses to l_pProcesses  \r
 748     zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
 749     getaddress of l_sStructBytesBack to l_pBytesBack\r
 750     \r
 751     move (EnumProcesses(l_pProcesses,l_iBytes,l_pBytesBack)) to l_iThrow\r
 752 \r
 753     getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack\r
 754     \r
 755     if (mod(l_iBytesBack,4) = 0) begin\r
 756         for l_i from 1 to (l_iBytesBack/4)\r
 757             move (left(l_sProcesses,4)) to l_sBuf\r
 758             move (mid(l_sProcesses,(length(l_sProcesses)-4),5)) to l_sProcesses\r
 759             getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iPid     \r
 760             move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess\r
 761             \r
 762             move 1024 to l_iBytes2\r
 763             zerostring l_iBytes2 to l_sModules\r
 764             getAddress of l_sModules to l_pModules\r
 765             zerotype _STRUCTBYTESBACK to l_sStructBytesBack\r
 766             getaddress of l_sStructBytesBack to l_pBytesBack2\r
 767             \r
 768             move (EnumProcessModules(l_hProcess,l_pModules,l_iBytes2,l_pBytesBack2)) to l_iThrow\r
 769             getbuff from l_sStructBytesBack at STRUCTBYTESBACK.integer0 to l_iBytesBack2\r
 770             \r
 771             // Err here            \r
 772             showln l_i  " PROC=" l_iPid " BYTES=" l_iBytesBack2 " H=" l_hProcess " LERR=" (GetLastError())\r
 773             \r
 774             // showln l_iBytesBack2 " " l_hProcess\r
 775             if (mod(l_iBytesBack2,4) = 0) begin\r
 776                 for l_j from 1 to (l_iBytesBack2/4)\r
 777                     move (left(l_sModules,4)) to l_sBuf\r
 778                     move (mid(l_sModules,(length(l_sModules)-4),5)) to l_sModules\r
 779                     getbuff from l_sBuf at PROCESSARRAY.arrayItem to l_iMid\r
 780 \r
 781                 loop\r
 782             end\r
 783             move (CloseHandle(l_hProcess)) to l_iThrow\r
 784             \r
 785         loop\r
 786     end\r
 787         \r
 788     showln l_iThrow\r
 789     showln "BYTES " l_iBytesBack\r
 790     \r
 791     function_return 0\r
 792 end_function\r
 793 \r
 794 // Returns the current system time via the GetSystemTime call\r
 795 // Takes an integer value; \r
 796 //     1 - displays individual segments comma separated\r
 797 //     0 - displays a formatted date time\r
 798 function time_data global integer argv returns string\r
 799     local string sTimeData sResult sFormattedTime sFormattedDate\r
 800     local pointer pTimeData pFormattedTime pFormattedDate\r
 801     local integer iThrow iYear iMonth iDayOfWeek iDay iHour iMinute iSecond iMilliSeconds iLenCcTime iLenCcDate iDataLength\r
 802     \r
 803     zeroType _SYSTEMTIME to sTimeData\r
 804     getAddress of sTimeData to pTimeData\r
 805     move (GetSystemTime(pTimeData)) to iThrow\r
 806     \r
 807     // just return the structure comma separated\r
 808     if (argv = 1) begin\r
 809         getBuff from sTimeData at SYSTEMTIME.wYear to iYear\r
 810         getBuff from sTimeData at SYSTEMTIME.wMonth to iMonth\r
 811         getBuff from sTimeData at SYSTEMTIME.wDayOfWeek to iDayOfWeek\r
 812         getBuff from sTimeData at SYSTEMTIME.wDay to iDay\r
 813         getBuff from sTimeData at SYSTEMTIME.wHour to iHour\r
 814         getBuff from sTimeData at SYSTEMTIME.wMinute to iMinute\r
 815         getBuff from sTimeData at SYSTEMTIME.wSecond to iSecond\r
 816         getBuff from sTimeData at SYSTEMTIME.wMilliSeconds to iMilliSeconds\r
 817         \r
 818         move "" to sResult\r
 819         append sResult iYear "," iMonth "," iDay "," iHour "," iMinute "," iSecond "," iMilliSeconds\r
 820     end \r
 821     // give formatted date_time\r
 822     if (argv = 0) begin \r
 823         zerostring 255 to sFormattedTime\r
 824         getaddress of sFormattedTime to pFormattedTime\r
 825         move (length(sFormattedTime)) to iLenCcTime\r
 826     \r
 827         move (GetTimeFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedTime, iLenCcTime)) to iDataLength\r
 828 \r
 829         zerostring 255 To sFormattedDate\r
 830         getaddress of sFormattedDate To pFormattedDate\r
 831         move (length(sFormattedDate)) to iLenCcDate\r
 832     \r
 833         move (GetDateFormat("LOCALE_USER_DEFAULT", 0, pTimeData, 0, pFormattedDate, iLenCcDate)) to iDataLength\r
 834         move (cstring(sFormattedDate)) to sResult\r
 835         append sResult " " (cstring(sFormattedTime)) // terminating null char removed    \r
 836     end\r
 837     function_return sResult\r
 838 end_function\r
 839 \r
 840 // Insert zeros into the correct places to make a field x wide (similar to zeropad)\r
 841 function fill_0 global integer iValue integer iSize returns string\r
 842     local string sReturn\r
 843 \r
 844     move iValue to sReturn\r
 845     while (length(sReturn) < iSize)\r
 846         insert '0' in sReturn at 1\r
 847     end\r
 848 \r
 849     function_return sReturn\r
 850 end_function\r
 851 \r
 852 // Checks the runtime date format and if it's not adding on the epoch add it\r
 853 function check_date_error global string sDate returns date\r
 854     local integer iDate iY1k\r
 855     local Date    dDate\r
 856 \r
 857     move sDate to iDate\r
 858     move 693975 to iY1k\r
 859 \r
 860     if (iDate < iY1k) Calc (iDate + iY1k) to iDate\r
 861     move iDate to dDate\r
 862 \r
 863     function_return dDate\r
 864 end_function\r
 865 \r
 866 // Get the mod time of a file\r
 867 // This is the core of the replacement / leap year fix of GET_FILE_MOD_TIME\r
 868 // Usage:\r
 869 // get_time(<file>, <mode>)\r
 870 //     1 = created time\r
 871 //     2 = accessed time\r
 872 //     3 = modified time\r
 873 // \r
 874 function get_time global string sFileName integer iMode returns string\r
 875     local string  sCreated sLastAccess sLastChanged sSystemTime sLocalTime sDate sTime sDateSep\r
 876     Local pointer pCreated pLastAccess pLastChanged pSystemTime pLocalTime pFileName\r
 877     Local handle  hCheckFile\r
 878     Local integer iResult iVal iDateSep iDateFormat iDate4State\r
 879 \r
 880     move "" to sTime\r
 881     move "" to sDate\r
 882     \r
 883     getaddress of sFileName to pFileName\r
 884     move (CreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING , 0, 0)) to hCheckFile\r
 885     \r
 886     if (hCheckFile <> INVALID_HANDLE_VALUE) begin\r
 887         zerotype _FILETIME to sCreated\r
 888         zerotype _FILETIME to sLastAccess\r
 889         zerotype _FILETIME to sLastChanged\r
 890         zerotype _FILETIME to sLocalTime\r
 891         getAddress of sCreated to pCreated\r
 892         getAddress of sLastAccess to pLastAccess\r
 893         getAddress of sLastChanged to pLastChanged\r
 894         getAddress of sLocalTime to pLocalTime\r
 895 \r
 896         move (GetFileTime (hCheckFile, pCreated, pLastAccess, pLastChanged)) to iResult \r
 897           \r
 898         if (iResult) begin\r
 899             if (iMode = 1) move (FileTimeToLocalFileTime(pCreated,pLocalTime)) to iResult\r
 900             else if (iMode = 2) move (FileTimeToLocalFileTime(pLastAccess,  pLocalTime)) to iResult\r
 901             else if (iMode = 3) move (FileTimeToLocalFileTime(pLastChanged, pLocalTime)) to iResult\r
 902             \r
 903             zerotype _SYSTEMTIME2 to sSystemTime\r
 904             getAddress of sSystemTime to pSystemTime\r
 905 \r
 906             move (FileTimeToSystemTime(pLocalTime, pSystemTime)) to iResult\r
 907 \r
 908             get_attribute DF_DATE_SEPARATOR to iDateSep\r
 909             move (character(iDateSep))   to sDateSep\r
 910             get_attribute DF_DATE_FORMAT to iDateFormat\r
 911 \r
 912             if (iDateFormat = DF_DATE_USA) begin\r
 913                 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
 914                 append sDate (fill_0(iVal,2))\r
 915                 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
 916                 append sDate sDateSep (fill_0(iVal,2))\r
 917                 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
 918                 append sDate sDateSep (fill_0(iVal,4))\r
 919             end\r
 920             else if iDateFormat eq DF_DATE_EUROPEAN begin\r
 921                 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
 922                 append sDate (fill_0(iVal,2))\r
 923                 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
 924                 append sDate sDateSep (fill_0(iVal,2))\r
 925                 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
 926                 append sDate sDateSep (fill_0(iVal,4))\r
 927             end\r
 928             else if iDateFormat eq DF_DATE_MILITARY begin\r
 929                 getbuff from sSystemTime at SYSTEMTIME2.wYear to iVal\r
 930                 append sDate (fill_0(iVal,4))\r
 931                 getbuff from sSystemTime at SYSTEMTIME2.wMonth to iVal\r
 932                 append sDate sDateSep (fill_0(iVal,2))\r
 933                 getbuff from sSystemTime at SYSTEMTIME2.wDay to iVal\r
 934                 append sDate sDateSep (fill_0(iVal,2))\r
 935             end\r
 936 \r
 937             getbuff from sSystemTime at SYSTEMTIME2.wHour to iVal\r
 938             append sTime (fill_0(iVal,2))\r
 939             getbuff from sSystemTime at SYSTEMTIME2.wMinute to iVal\r
 940             append sTime ":" (fill_0(iVal,2))\r
 941             getbuff from sSystemTime at SYSTEMTIME2.wSecond to iVal\r
 942             append sTime ":" (fill_0(iVal,2))\r
 943 \r
 944             append sDate sTime\r
 945         end\r
 946         move (CloseHandle (hCheckFile)) to iResult\r
 947     end\r
 948 \r
 949     function_return sDate\r
 950 end_function\r
 951 \r
 952 // Create a guid GUID (Microsoft)\r
 953 function create_guid global returns string        \r
 954     local integer l_iThrow\r
 955     local pointer l_ptGUID l_ptGUIDString\r
 956     local string l_stGUID l_stGUIDString l_sResult\r
 957    \r
 958     zerotype _GUID to l_stGUID\r
 959     getaddress of l_stGUID to l_ptGUID\r
 960 \r
 961     zerostring GUID_STRING_LENGTH to l_stGUIDString\r
 962     getaddress of l_stGUIDString to l_ptGUIDString\r
 963     \r
 964     if (CoCreateGuid(l_ptGUID) = 0) begin\r
 965         // If successfully created put it in a string\r
 966         move (StringFromGUID2(l_ptGUID, l_ptGUIDString, GUID_STRING_LENGTH)) to l_iThrow\r
 967         move (cstring(to_ascii(l_stGUIDString))) to l_sResult\r
 968     end\r
 969     \r
 970     function_return l_sResult\r
 971 end_function\r
 972 \r
 973 // Get textual description of a win32 error returned by GetLastError()\r
 974 function get_last_error_detail global integer iError returns string\r
 975     local integer l_iThrow\r
 976     local string l_sBuf \r
 977     local pointer l_pBuf\r
 978     \r
 979     zerostring 200 to l_sBuf\r
 980     getaddress of l_sBuf to l_pBuf\r
 981     \r
 982     move (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, iError, LANG_NEUTRAL, l_pBuf, 200, 0)) to l_iThrow\r
 983     \r
 984     function_return (string(iError)+": "+l_sBuf)\r
 985 end_function\r
 986 \r
 987 // Get system disk info\r
 988 // argv1 = disk mount point i.e. c:\\r
 989 // argv2 = "" or "TOTAL", where TOTAL returns free and blank displays used.\r
 990 function disk_info global string argv string argv2 returns number\r
 991     local string l_sSectorsPerCluster l_sBytesPerSector l_sNumberOfFreeClusters l_sTotalNumberOfClusters\r
 992     local pointer l_pSectorsPerCluster l_pBytesPerSector l_pNumberOfFreeClusters l_pTotalNumberOfClusters\r
 993     local number l_iSectorsPerCluster l_iBytesPerSector l_iNumberOfFreeClusters l_iTotalNumberOfClusters l_iSpace\r
 994     \r
 995     move 0 to l_iSpace\r
 996 \r
 997     if (argv <> "") begin\r
 998         zerotype _DISKDATA1 to l_sSectorsPerCluster\r
 999         zerotype _DISKDATA2 to l_sBytesPerSector \r
1000         zerotype _DISKDATA3 to l_sNumberOfFreeClusters \r
1001         zerotype _DISKDATA4 to l_sTotalNumberOfClusters\r
1002 \r
1003         getaddress of l_sSectorsPerCluster to l_pSectorsPerCluster\r
1004         getaddress of l_sBytesPerSector to l_pBytesPerSector\r
1005         getaddress of l_sNumberOfFreeClusters to l_pNumberOfFreeClusters\r
1006         getaddress of l_sTotalNumberOfClusters to l_pTotalNumberOfClusters\r
1007 \r
1008         showln (GetDiskFreeSpace(argv, l_pSectorsPerCluster, l_pBytesPerSector, l_pNumberOfFreeClusters, l_pTotalNumberOfClusters))\r
1009 \r
1010         getbuff from l_sSectorsPerCluster at DISKDATA1.sectorsPerCluster to l_iSectorsPerCluster\r
1011         getbuff from l_sBytesPerSector at DISKDATA2.bytesPerSector to l_iBytesPerSector\r
1012         getbuff from l_sNumberOfFreeClusters at DISKDATA3.numberOfFreeClusters to l_iNumberOfFreeClusters\r
1013         getbuff from l_sTotalNumberOfClusters at DISKDATA4.totalNumberOfClusters to l_iTotalNumberOfClusters\r
1014 \r
1015         // showln l_iSectorsPerCluster\r
1016         // showln l_iBytesPerSector \r
1017         // showln l_iNumberOfFreeClusters\r
1018         // showln l_iTotalNumberOfClusters\r
1019         \r
1020         if (argv2 = "TOTAL") calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iTotalNumberOfClusters) to l_iSpace\r
1021         else calc (l_iSectorsPerCluster*l_iBytesPerSector*l_iNumberOfFreeClusters) to l_iSpace\r
1022     end\r
1023     \r
1024     function_return l_iSpace\r
1025 end_function\r
1026 \r
1027 // Get system memory usage\r
1028 function get_mem_usage global returns integer\r
1029     local integer l_iThrow l_iPid l_iMem\r
1030     local string l_sProcessMemoryCounters\r
1031     local pointer l_lpProcessMemoryCounters\r
1032     local handle l_hProcess\r
1033 \r
1034     zeroType _PROCESS_MEMORY_COUNTERS to l_sProcessMemoryCounters\r
1035     getaddress of l_sProcessMemoryCounters to l_lpProcessMemoryCounters\r
1036 \r
1037     put (length(l_sProcessMemoryCounters)) to l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.cb\r
1038 \r
1039     move (get_process_id(0)) to l_iPid\r
1040     move (OpenProcess((PROCESS_VM_READ ior PROCESS_QUERY_INFORMATION),HEXNULL,l_iPid)) to l_hProcess\r
1041 \r
1042     move (GetProcessMemoryInfo(l_hProcess, l_lpProcessMemoryCounters, length(l_sProcessMemoryCounters))) to l_iThrow\r
1043     getbuff from l_sProcessMemoryCounters at PROCESS_MEMORY_COUNTERS.WorkingSetSize to l_iMem\r
1044     \r
1045     // showln l_hProcess " " l_iThrow\r
1046     // showln (GetLastError())\r
1047     // showln (get_last_error_detail(GetLastError()))\r
1048 \r
1049     function_return l_iMem\r
1050 end_function\r
1051 \r
1052 // Uses Microsofts InternetCanonicalizeUrl functionality\r
1053 // http:// msdn.microsoft.com/en-us/library/windows/desktop/aa384342%28v=vs.85%29.aspx\r
1054 // https:// groups.google.com/forum/#!topic/microsoft.public.vb.winapi/0RY8jPsx_14\r
1055 function urldecode global string argv returns string\r
1056     local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult\r
1057     local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength \r
1058     local integer l_iwBufferLength l_iResult l_iDllErr\r
1059 \r
1060     move argv to l_szUrl\r
1061     move argv to l_sResult\r
1062     \r
1063     if (length(l_szUrl) > 0) begin\r
1064         zerostring ((length(l_szUrl))+1) to l_szBuffer\r
1065         getaddress of l_szUrl to l_lpszUrl\r
1066         getaddress of l_szBuffer to l_lpszBuffer\r
1067         \r
1068         zerotype _STRUCTBYTESREAD to l_szStructBytesRead\r
1069         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
1070         getaddress of l_szStructBytesRead to l_lpdwBufferLength\r
1071 \r
1072         move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_NO_ENCODE+ICU_DECODE)) to l_iResult\r
1073 \r
1074         getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
1075 \r
1076         if (l_iResult <> 1) begin\r
1077             move (GetLastError()) to l_iDllErr\r
1078             custom_error ERROR_CODE_URLDECODE$ ERROR_MSG_URLDECODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))\r
1079         end\r
1080         move (cstring(l_szBuffer)) to l_sResult     \r
1081     end        \r
1082     function_return l_sResult        \r
1083 end_function\r
1084 \r
1085 // Uses Microsofts InternetCanonicalizeUrl functionality\r
1086 // Only encodes parts before ? and #\r
1087 function urlencode global string argv returns string\r
1088     local string l_szUrl l_szBuffer l_szStructBytesRead l_sResult\r
1089     local pointer l_lpszUrl l_lpszBuffer l_lpdwBufferLength \r
1090     local integer l_iwBufferLength l_iResult l_iDllErr\r
1091 \r
1092     move argv to l_szUrl\r
1093     move argv to l_sResult\r
1094     if (length(l_szUrl) > 0) begin\r
1095         zerostring ((length(l_szUrl))+1) to l_szBuffer\r
1096         getaddress of l_szUrl to l_lpszUrl\r
1097         getaddress of l_szBuffer to l_lpszBuffer\r
1098         \r
1099         zerotype _STRUCTBYTESREAD to l_szStructBytesRead\r
1100         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
1101         getaddress of l_szStructBytesRead to l_lpdwBufferLength\r
1102 \r
1103         move (InternetCanonicalizeUrl(l_lpszUrl, l_lpszBuffer, l_lpdwBufferLength, ICU_BROWSER_MODE)) to l_iResult\r
1104 \r
1105         getbuff from l_szStructBytesRead at STRUCTBYTESREAD.integer0 to l_iwBufferLength\r
1106 \r
1107         if (l_iResult <> 1) begin\r
1108             move (GetLastError()) to l_iDllErr\r
1109             custom_error ERROR_CODE_URLENCODE$ ERROR_MSG_URLENCODE ERROR_DETAIL_GETLASTERROR (get_last_error_detail(l_iDllErr))\r
1110         end\r
1111         move (cstring(l_szBuffer)) to l_sResult     \r
1112     end        \r
1113     function_return l_sResult        \r
1114 end_function\r
1115 \r
1116 // Functions to pull windows os version string\r
1117 function get_os_version global returns string\r
1118     local string l_sOsInfo l_sVersion l_sReturn\r
1119     local pointer l_pOsInfo\r
1120     local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform\r
1121     \r
1122     move "" to l_sVersion\r
1123     \r
1124     zerotype _OSVERSIONINFO to  l_sOsInfo\r
1125     put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize\r
1126     getaddress of l_sOsInfo to  l_pOsInfo\r
1127     \r
1128     move (GetVersionEx(l_pOsInfo)) to l_iResult\r
1129     \r
1130     if (l_iResult = 1) begin\r
1131         getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor\r
1132         getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor\r
1133         getbuff from l_sOsInfo at OSVERSIONINFO.dwBuildNumber to l_iBuild\r
1134         getbuff from l_sOsInfo at OSVERSIONINFO.dwPlatformId to l_iPlatform\r
1135         // getbuff from l_sOsInfo at OSVERSIONINFO.szCSDVersion to l_sVersion    !??\r
1136         move (cstring(right(l_sOsInfo,128))) to l_sVersion\r
1137     end\r
1138     \r
1139     move ("Windows Version: "+string(l_iMajor)+"."+string(l_iMinor)+" Build: "+string(l_iBuild)+" Platform: "+string(l_iPlatform)+" CSDVersion: "+l_sVersion) to l_sReturn\r
1140     \r
1141     function_return l_sReturn \r
1142 end_function\r
1143 \r
1144 // Functions to pull windows os version as a numeric value\r
1145 function get_os_version_numeric global returns number\r
1146     local string l_sOsInfo l_sVersion\r
1147     local pointer l_pOsInfo\r
1148     local integer l_iResult l_iMajor l_iMinor l_iBuild l_iPlatform\r
1149     \r
1150     move "" to l_sVersion\r
1151     \r
1152     zerotype _OSVERSIONINFO to  l_sOsInfo\r
1153     put (length(l_sOsInfo)) to l_sOsInfo at OSVERSIONINFO.dwOSVersionInfoSize\r
1154     getaddress of l_sOsInfo to  l_pOsInfo\r
1155     \r
1156     move (GetVersionEx(l_pOsInfo)) to l_iResult\r
1157     \r
1158     if (l_iResult = 1) begin\r
1159         getbuff from l_sOsInfo at OSVERSIONINFO.dwMajorVersion to l_iMajor\r
1160         getbuff from l_sOsInfo at OSVERSIONINFO.dwMinorVersion to l_iMinor\r
1161     end\r
1162     \r
1163     function_return (number(l_iMajor)+(number(l_iMinor)/10))\r
1164 end_function\r
1165 \r
1166 // Converts binary to hex or base64 strings and vice versa\r
1167 function binary_to_string_to_binary global string argv string argv2 string argv3 returns string\r
1168     local string l_sData l_sDataDecoded l_sDataSizeDecoded l_sReturn\r
1169     local pointer l_pData l_pDataDecoded l_pDataSizeDecoded\r
1170     local integer l_iResult l_iDataSize l_iDataSizeDecoded l_iOffset\r
1171     \r
1172     move argv to l_sData\r
1173     move (length(l_sData)) to l_iDataSize\r
1174     getaddress of l_sData to l_pData\r
1175      \r
1176     zerostring ((length(l_sData)*4)+1) to l_sDataDecoded\r
1177     getaddress of l_sDataDecoded to l_pDataDecoded\r
1178             \r
1179     zerotype _DW_TYPE to l_sDataSizeDecoded\r
1180     put (length(l_sDataDecoded)) to l_sDataSizeDecoded at DW_TYPE.value\r
1181     getaddress of l_sDataSizeDecoded to l_pDataSizeDecoded      \r
1182     \r
1183     case begin\r
1184         case (argv2 = "HEX") begin\r
1185             if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult\r
1186             if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_HEX, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult\r
1187         end\r
1188         case break\r
1189         case (argv2 = "BASE64") begin\r
1190             if (argv3 = 0) move (CryptBinaryToString(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded)) to l_iResult\r
1191             if (argv3 = 1) move (CryptStringToBinary(l_pData, l_iDataSize, CRYPT_STRING_BASE64, l_pDataDecoded, l_pDataSizeDecoded, HEXNULL, HEXNULL)) to l_iResult\r
1192         end\r
1193         case break\r
1194         case else custom_error ERROR_CODE_UNKNOWN_FORMAT$ ERROR_MSG_UNKNOWN_FORMAT argv2\r
1195     case end\r
1196 \r
1197     getbuff from l_sDataSizeDecoded at DW_TYPE.value to l_iDataSizeDecoded\r
1198 \r
1199     if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1200         showln "ERROR: " (ternary(argv3 = 0, "CryptBinaryToString", "CryptStringToBinary")) " "  l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1201         showln "DATA = " l_sDataDecoded\r
1202         showln "SIZE = " l_iDataSizeDecoded\r
1203     end\r
1204     else begin\r
1205         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
1206         else move (cstring(mid(l_sDataDecoded,l_pDataSizeDecoded-l_iOffset,1+l_iOffset))) to l_sReturn\r
1207     end\r
1208     \r
1209     function_return l_sReturn\r
1210 end_function\r
1211 \r
1212 // Convert binary data to hex or base64 \r
1213 function binary_to_string global string argv string argv2 returns string\r
1214     function_return (binary_to_string_to_binary(argv, argv2, 0))\r
1215 end_function\r
1216 // Convert hex or base64 strings to binary data\r
1217 function string_to_binary global string argv string argv2 returns string\r
1218     function_return (binary_to_string_to_binary(argv, argv2, 1))\r
1219 end_function\r
1220 \r
1221 // List out cryptographic providers on ms windows\r
1222 function ms_adv_listproviders global returns integer\r
1223     local integer l_i l_iResult l_iType\r
1224     local string l_sType l_sName l_sNameSize\r
1225     local pointer l_pType l_pName l_pNameSize\r
1226 \r
1227     move -1 to l_i\r
1228     repeat\r
1229         increment l_i\r
1230         \r
1231         zerotype _DW_TYPE to l_sType\r
1232         getaddress of l_sType to l_pType\r
1233         \r
1234         zerostring 255 to l_sName\r
1235         getaddress of l_sName to l_pName\r
1236         \r
1237         zerotype _DW_TYPE to l_sNameSize\r
1238         put length(l_sName) to l_sNameSize at DW_TYPE.value\r
1239         getaddress of l_sNameSize to l_pNameSize\r
1240     \r
1241         move (CryptEnumProviders(l_i, HEXNULL, 0, l_pType, l_pName, l_pNameSize)) to l_iResult\r
1242 \r
1243         if ((l_iResult <> 1) and (GetLastError() <> 0) and (GetLastError() <> 259)) begin\r
1244             showln "ERROR: " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1245         end\r
1246         getbuff from l_sType at DW_TYPE.value to l_iType\r
1247         \r
1248         if (l_iResult = 1) showln l_i ") " l_iType " - '" (cstring(l_sName)) "'"\r
1249     until (l_iResult <> 1)\r
1250 \r
1251 end_function\r
1252 \r
1253 //-------------------------------------------------------------------------\r
1254 // Classes\r
1255 //-------------------------------------------------------------------------\r
1256 \r
1257 // Object to provide basic implimentations of some popular hash algorithms and encryption\r
1258 // provided by the Microsoft Cryptographic Provider\r
1259 //\r
1260 // Send message methods:\r
1261 //\r
1262 //    aquire_context                - Create the context of the Microsoft CSP\r
1263 //    release_context               - Release the context of the Microsoft CSP\r
1264 //    import_key <key> <ealg>       - Incomplete/WIP\r
1265 //    derive_key <psw> <halg> <ealg>- Derives an encryption key provider when supplied\r
1266 //                                    with a password, a hash algorithm and the required \r
1267 //                                    encryption.\r
1268 //    modify_key_iv <iv>            - Set the initilization vector of the key provider\r
1269 //    modify_key_mode <mode>        - Set the key provider mode E.g. CBC, ECB etc\r
1270 //    destroy_key                   - Dispose of the current key provider\r
1271 //\r
1272 // Get methods:\r
1273 //    hash_data <data> <halg>       - Returns a hash of the passed data in the specified \r
1274 //                                    algorithm\r
1275 //    export_key                    - Returns the current encryption key\r
1276 //    generate_random_key_iv        - Generates and sets a random initilization vector \r
1277 //                                    for the key provider\r
1278 //    encrypt <data>                - Encrypt data\r
1279 //    decrypt <data>                - Decrypt data\r
1280 //\r
1281 // Example usage:\r
1282 //    \r
1283 //    object test is an msAdvCrypt\r
1284 //    end_object\r
1285 //    string data buf\r
1286 //    \r
1287 //    // Generate a hash\r
1288 //    send aquire_context to test\r
1289 //    get hash_data of test "MYTEXT" "SHA1" to data\r
1290 //    send release_context to test\r
1291 //    showln "HASHED: " (binary_to_string(data,"HEX"))\r
1292 //    \r
1293 //    // Encrypt some data\r
1294 //    send aquire_context to test\r
1295 //    send derive_key to test "MYPASSWORD" "SHA256" "AES_256"\r
1296 //    send modify_key_mode to test "CBC"\r
1297 //    get generate_random_key_iv of test to buf\r
1298 //    move buf to data\r
1299 //    get encrypt of test "MYDATA" to buf\r
1300 //    append data buf\r
1301 //    send destroy_key to test\r
1302 //    send release_context to test\r
1303 //    showln "ENCRYPTED: " (binary_to_string(data,"HEX"))\r
1304 //    \r
1305 //    // Decrypt some data\r
1306 //    send aquire_context to test\r
1307 //    send derive_key to test "MYPASSWORD" "SHA256" "AES_256"\r
1308 //    send modify_key_mode to test "CBC"\r
1309 //    send modify_key_iv to test (mid(data,16,1))\r
1310 //    get decrypt of test (mid(data,length(data)-16,17)) to data\r
1311 //    send destroy_key to test\r
1312 //    send release_context to test\r
1313 //    showln "DECRYPTED: " data\r
1314 //    \r
1315 class msAdvCrypt is an array\r
1316     procedure construct_object string argc \r
1317         forward send construct_object argc\r
1318         \r
1319         property handle c_hProv \r
1320         property handle c_hHash \r
1321         property handle c_hKey\r
1322         property string c_sAlg\r
1323     end_procedure\r
1324 \r
1325     procedure aquire_context\r
1326         local integer l_iResult\r
1327         local handle l_hProv\r
1328         local string l_shProv\r
1329         local pointer l_phProv\r
1330         \r
1331         zerotype _DW_TYPE to l_shProv\r
1332         getaddress of l_shProv to l_phProv\r
1333         \r
1334         if (get_os_version_numeric() < 5.2) begin\r
1335             move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult\r
1336             if (GetLastError() = -2146893802) begin\r
1337                 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV_XP, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult\r
1338             end\r
1339         end\r
1340         else begin\r
1341             move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)) to l_iResult\r
1342             if (GetLastError() = -2146893802) begin\r
1343                 move (CryptAcquireContext(l_phProv, HEXNULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_NEWKEYSET)) to l_iResult\r
1344             end\r
1345         end\r
1346         \r
1347         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1348             showln "ERROR: CryptAcquireContext " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1349         end\r
1350         else begin\r
1351             getbuff from l_shProv at DW_TYPE.value to l_hProv\r
1352             set c_hProv to l_hProv\r
1353         end        \r
1354     end_procedure\r
1355     \r
1356     function make_hash string in_data string in_hashalgorithm returns string\r
1357         local integer l_iResult l_iHashSize\r
1358         local string l_shHash l_sHash l_sRawString l_sHashSize\r
1359         local handle l_hProv l_hHash\r
1360         local pointer l_phHash l_pHash l_pRawString l_pHashSize\r
1361         \r
1362         get c_hProv to l_hProv\r
1363         \r
1364         if (l_hProv = 0) begin\r
1365             custom_error ERROR_CODE_NO_CONTEXT$ ERROR_MSG_NO_CONTEXT\r
1366         end\r
1367         else begin\r
1368             move in_data to l_sRawString\r
1369             getaddress of l_sRawString to l_pRawString\r
1370             \r
1371             zerotype _HCRYPTHASH to l_shHash\r
1372             getaddress of l_shHash to l_phHash        \r
1373     \r
1374             case begin\r
1375                 case (in_hashalgorithm = "MD5") begin\r
1376                     move (CryptCreateHash(l_hProv, CALG_MD5, 0, 0, l_phHash)) to l_iResult\r
1377                     zerostring (128/8) to l_sHash\r
1378                 end\r
1379                 case break  \r
1380                 case ((in_hashalgorithm = "SHA1") or (in_HASHalgorithm = "SHA")) begin\r
1381                     move (CryptCreateHash(l_hProv, CALG_SHA1, 0, 0, l_phHash)) to l_iResult\r
1382                     zerostring (160/8) to l_sHash\r
1383                 end\r
1384                 case break\r
1385                 case (in_hashalgorithm = "SHA256") begin\r
1386                     move (CryptCreateHash(l_hProv, CALG_SHA_256, 0, 0, l_phHash)) to l_iResult\r
1387                     zerostring (256/8) to l_sHash           \r
1388                 end\r
1389                 case break\r
1390                 case (in_hashalgorithm = "SHA384") begin\r
1391                     move (CryptCreateHash(l_hProv, CALG_SHA_384, 0, 0, l_phHash)) to l_iResult\r
1392                     zerostring (384/8) to l_sHash           \r
1393                 end\r
1394                 case break\r
1395                 case (in_hashalgorithm = "SHA512") begin\r
1396                     move (CryptCreateHash(l_hProv, CALG_SHA_512, 0, 0, l_phHash)) to l_iResult\r
1397                     zerostring (512/8) to l_sHash                    \r
1398                 end\r
1399                 case break  \r
1400                 case else begin\r
1401                     custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_hashalgorithm\r
1402                 end\r
1403             case end        \r
1404         \r
1405             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1406                 showln "ERROR: CryptCreateHash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1407             end\r
1408         \r
1409             getbuff from l_shHash at HCRYPTHASH.value to l_hHash\r
1410             getaddress of l_sHash to l_pHash\r
1411         \r
1412             move (CryptHashData(l_hHash, l_pRawString, (length(l_sRawString)), 0)) to l_iResult\r
1413         \r
1414             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1415                 showln "ERROR: Crypthash_data " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1416             end\r
1417         \r
1418             zerotype _DW_TYPE to l_sHashSize\r
1419             put (length(l_sHash)) to l_sHashSize at DW_TYPE.value\r
1420             getaddress of l_sHashSize to l_pHashSize\r
1421     \r
1422             move (CryptGetHashParam(l_hHash, HP_HASHVAL, l_pHash, l_pHashSize, 0)) to l_iResult\r
1423         \r
1424             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1425                 showln "ERROR: CryptGetHashParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1426             end    \r
1427         \r
1428             getbuff from l_sHashSize at DW_TYPE.value to l_iHashSize\r
1429 \r
1430             if (l_iHashSize <> length(l_sHash)) begin\r
1431                 showln "WARNING: Binary data does not match expected hash size:"\r
1432                 showln "DATA = " l_sHash\r
1433                 showln "SIZE = " l_iHashSize " / " (length(l_sHash))\r
1434             end        \r
1435         end\r
1436     \r
1437         set c_hHash to l_hHash        \r
1438    \r
1439         function_return (mid(l_sHash,l_iHashSize,1))\r
1440     end_function \r
1441         \r
1442     procedure destroy_hash\r
1443         local integer l_iResult\r
1444         local handle l_hHash\r
1445         \r
1446         get c_hHash to l_hHash\r
1447 \r
1448         if (l_hHash <> 0) begin\r
1449             move (CryptDestroyHash(l_hHash)) to l_iResult\r
1450             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1451                 showln "ERROR: Cryptdestroy_hash " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1452             end        \r
1453             else set c_hHash to 0\r
1454         end        \r
1455     end_procedure\r
1456 \r
1457     function hash_data string in_data string in_hashalgorithm returns string\r
1458         local integer l_iResult\r
1459         local string l_sHash\r
1460         \r
1461         get make_hash in_data in_hashalgorithm to l_sHash\r
1462         send destroy_hash\r
1463         \r
1464         function_return (cstring(l_sHash))\r
1465     end_function \r
1466     \r
1467     //WIP\r
1468     procedure import_key string in_key string in_algorithm\r
1469         local integer l_iResult\r
1470         local string l_sBlobHeader l_sPlainTextKeyBlob l_shKey\r
1471         local handle l_hProv l_hKey\r
1472         local pointer l_pPlainTextKeyBlob l_phKey\r
1473         \r
1474         get c_hProv to l_hProv   \r
1475         \r
1476         zerotype _BLOBHEADER to l_sBlobHeader \r
1477         put PLAINTEXTKEYBLOB to l_sBlobHeader at BLOBHEADER.bType\r
1478         put 2 to l_sBlobHeader at BLOBHEADER.bVersion\r
1479         put 0 to l_sBlobHeader at BLOBHEADER.Reserved\r
1480         \r
1481         case begin        \r
1482             case (in_algorithm = "DES") put CALG_DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1483             case break \r
1484             case (in_algorithm = "3DES") put CALG_3DES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1485             case break \r
1486             case (in_algorithm = "3DES_112") put CALG_3DES_112 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1487             case break \r
1488             case (in_algorithm = "AES") put CALG_AES to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1489             case break \r
1490             case (in_algorithm = "AES_128") put CALG_AES_128 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1491             case break \r
1492             case (in_algorithm = "AES_192") put CALG_AES_192 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1493             case break \r
1494             case (in_algorithm = "AES_256") put CALG_AES_256 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1495             case break \r
1496             case (in_algorithm = "RC2") put CALG_RC2 to l_sBlobHeader at BLOBHEADER.ALG_ID\r
1497             case break \r
1498             case (in_algorithm = "RC4") put CALG_RC4 to l_sBlobHeader at BLOBHEADER.ALG_ID        \r
1499             case break \r
1500             case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
1501         case end\r
1502         \r
1503         zerotype _PLAINTEXTKEYBLOB to l_sPlainTextKeyBlob\r
1504         put l_sBlobHeader to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.BLOBHEADER\r
1505         put (length(in_key)) to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.dwKeySize\r
1506         put_string in_key to l_sPlainTextKeyBlob at PLAINTEXTKEYBLOB.rgbKeyData       \r
1507         \r
1508         getaddress of l_sPlainTextKeyBlob to l_pPlainTextKeyBlob\r
1509         \r
1510         zerotype _HCRYPTKEY to l_shKey\r
1511         getaddress of l_shKey to l_phKey\r
1512         \r
1513         move (CryptImportKey(l_hProv, l_pPlainTextKeyBlob, length(l_sPlainTextKeyBlob), 0, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1514         \r
1515         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1516             showln "ERROR: CryptImportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1517         end\r
1518             \r
1519         getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
1520         \r
1521     end_procedure\r
1522     \r
1523     procedure derive_key string in_data string in_hashalgorithm string in_algorithm\r
1524         local integer l_iResult\r
1525         local handle l_hProv l_hHash l_hKey\r
1526         local string l_sKey l_shKey\r
1527         local pointer l_phKey\r
1528         \r
1529         get c_hProv to l_hProv        \r
1530         get make_hash in_data in_hashalgorithm to l_sKey        \r
1531         get c_hHash to l_hHash\r
1532 \r
1533         if (l_hHash <> 0) begin\r
1534             zerotype _HCRYPTKEY to l_shKey\r
1535             getaddress of l_shKey to l_phKey\r
1536 \r
1537             // 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
1538             case begin\r
1539                 case (in_algorithm = "DES") move (CryptDeriveKey(l_hProv, CALG_DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1540                 case break \r
1541                 case (in_algorithm = "3DES") move (CryptDeriveKey(l_hProv, CALG_3DES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1542                 case break \r
1543                 case (in_algorithm = "3DES_112") move (CryptDeriveKey(l_hProv, CALG_3DES_112, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1544                 case break \r
1545                 case (in_algorithm = "AES") move (CryptDeriveKey(l_hProv, CALG_AES, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1546                 case break \r
1547                 case (in_algorithm = "AES_128") move (CryptDeriveKey(l_hProv, CALG_AES_128, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1548                 case break \r
1549                 case (in_algorithm = "AES_192") move (CryptDeriveKey(l_hProv, CALG_AES_192, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1550                 case break \r
1551                 case (in_algorithm = "AES_256") move (CryptDeriveKey(l_hProv, CALG_AES_256, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1552                 case break \r
1553                 case (in_algorithm = "RC2") move (CryptDeriveKey(l_hProv, CALG_RC2, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1554                 case break \r
1555                 case (in_algorithm = "RC4") move (CryptDeriveKey(l_hProv, CALG_RC4, l_hHash, CRYPT_EXPORTABLE, l_phKey)) to l_iResult\r
1556                 case break \r
1557                 case else custom_error ERROR_CODE_UNKNOWN_ALGORITHM$ ERROR_MSG_UNKNOWN_ALGORITHM in_algorithm\r
1558             case end\r
1559             \r
1560             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1561                 showln "ERROR: CryptDeriveKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1562             end\r
1563             else begin        \r
1564                 getbuff from l_shKey at HCRYPTKEY.value to l_hKey\r
1565                 set c_sAlg to in_algorithm\r
1566             end\r
1567 \r
1568             set c_hKey to l_hKey\r
1569         end\r
1570     end_procedure\r
1571        \r
1572     procedure modify_key_iv string in_iv\r
1573         local integer l_iResult l_iBlockSize\r
1574         local handle l_hKey\r
1575         local string l_sIV l_sAlg\r
1576         local pointer l_pIV\r
1577         \r
1578         get c_hKey to l_hKey\r
1579         get c_sAlg to l_sAlg\r
1580         \r
1581         // Set expected block size in bytes\r
1582         case begin\r
1583             case (l_sAlg contains "DES") calc (64/8) to l_iBlockSize\r
1584             case break         \r
1585             case (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
1586             case break \r
1587             case (l_sAlg = "RC2") calc (64/8) to l_iBlockSize\r
1588             case break \r
1589             case else custom_error ERROR_CODE_INCOMPATIBLE_ALGORITHM$ ERROR_MSG_INCOMPATIBLE_ALGORITHM l_sAlg\r
1590         case end\r
1591         \r
1592         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
1593         \r
1594         move in_iv to l_sIV\r
1595         getaddress of l_sIV to l_pIV\r
1596         \r
1597         move (CryptSetKeyParam(l_hKey, KP_IV, l_pIV, 0)) to l_iResult\r
1598         \r
1599         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1600             showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1601         end        \r
1602         \r
1603     end_procedure\r
1604     \r
1605     function generate_random_key_iv returns string\r
1606         local integer l_i l_iBlockSize\r
1607         local string l_sIV l_sAlg        \r
1608      \r
1609         get c_sAlg to l_sAlg\r
1610         move "" to l_sIV\r
1611         \r
1612         if ((l_sAlg contains "DES") or (l_sAlg = "RC2")) calc (64/8) to l_iBlockSize\r
1613     if (l_sAlg contains "AES") calc (128/8) to l_iBlockSize\r
1614         \r
1615         for l_i from 1 to l_iBlockSize\r
1616             append l_sIV (character(48+random(47)))\r
1617         loop\r
1618         \r
1619         send modify_key_iv l_sIV\r
1620         \r
1621         function_return l_sIV\r
1622     end_function\r
1623     \r
1624     procedure modify_key_mode string in_mode\r
1625         local integer l_iResult\r
1626         local handle l_hKey\r
1627         local string l_sMode l_sbData\r
1628         local pointer l_pbData\r
1629         \r
1630         get c_hKey to l_hKey\r
1631 \r
1632         case begin\r
1633             case (in_mode contains "CBC") move CRYPT_MODE_CBC to l_sMode\r
1634             case break\r
1635             case (in_mode contains "ECB") move CRYPT_MODE_ECB to l_sMode\r
1636             case break\r
1637             case (in_mode contains "OFB") move CRYPT_MODE_OFB to l_sMode\r
1638             case break\r
1639             case (in_mode contains "CFB") move CRYPT_MODE_CFB to l_sMode\r
1640             case break\r
1641             case (in_mode contains "CTS") move CRYPT_MODE_CTS to l_sMode\r
1642             case break            \r
1643             case else custom_error ERROR_CODE_UNRECOGNISED_MODE$ ERROR_MSG_UNRECOGNISED_MODE l_sMode        \r
1644         case end\r
1645         \r
1646         zerotype _DW_TYPE to l_sbData\r
1647         put l_sMode to l_sbData at DW_TYPE.value\r
1648         getaddress of l_sbData to l_pbData       \r
1649         \r
1650         move (CryptSetKeyParam(l_hKey, KP_MODE, l_pbData, 0)) to l_iResult\r
1651         \r
1652         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1653             showln "ERROR: CryptSetKeyParam " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1654         end        \r
1655     \r
1656     end_procedure\r
1657     \r
1658     function export_key returns string\r
1659         local integer l_iResult\r
1660         local string l_sData l_sDataSize\r
1661         local handle l_hKey\r
1662         local pointer l_pData l_pDataSize\r
1663         local integer l_iKeyBlobSize l_iDataSize\r
1664         \r
1665         get c_hKey to l_hKey\r
1666         \r
1667         if (l_hKey <> 0) begin\r
1668             zerotype _PLAINTEXTKEYBLOB to l_sData\r
1669             getaddress of l_sData to l_pData\r
1670         \r
1671             zerotype _DW_TYPE to l_sDataSize\r
1672             put (length(l_sData)) to l_sDataSize at DW_TYPE.value\r
1673             getaddress of l_sDataSize to l_pDataSize\r
1674         \r
1675             move (CryptExportKey(l_hKey, 0, PLAINTEXTKEYBLOB, 0, l_pData, l_pDataSize)) to l_iResult\r
1676             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1677                 showln "ERROR: CryptExportKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1678             end \r
1679         \r
1680             getbuff from l_sDataSize at DW_TYPE.value to l_iKeyBlobSize\r
1681             getbuff from l_sData at PLAINTEXTKEYBLOB.dwKeySize to l_iDataSize\r
1682             move (mid(l_sData,l_iDataSize,13)) to l_sData\r
1683             \r
1684             if (show_debug_lines) begin\r
1685                 showln "DEBUG: Key blob Size = " l_iKeyBlobSize        \r
1686             end\r
1687        end\r
1688        function_return l_sData\r
1689     end_function\r
1690     \r
1691     function encrypt_decrypt string in_data integer in_decrypt returns string\r
1692         local integer l_iResult l_iDataSize\r
1693         local string l_sData l_sDataSize\r
1694         local pointer l_pData l_pDataSize \r
1695         local handle l_hKey\r
1696         \r
1697         move in_data to l_sData    \r
1698         get c_hKey to l_hKey\r
1699         \r
1700         zerotype _DW_TYPE to l_sDataSize\r
1701         put (length(l_sData)) to l_sDataSize at DW_TYPE.value\r
1702         getaddress of l_sDataSize to l_pDataSize                        \r
1703         \r
1704         move (l_sData+repeat(' ',length(l_sData)*2)) to l_sData\r
1705         getaddress of l_sData to l_pData        \r
1706         \r
1707         if (in_decrypt = 0) move (CryptEncrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize, length(l_sData))) to l_iResult\r
1708         else move (CryptDecrypt(l_hKey, HEXNULL, HEXTRUE, 0, l_pData, l_pDataSize)) to l_iResult             \r
1709 \r
1710         if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1711             showln "ERROR: " (ternary(in_decrypt = 0, "CryptEncrypt", "CryptDecrypt")) " " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1712         end\r
1713         \r
1714         getbuff from l_sDataSize at DW_TYPE.value to l_iDataSize\r
1715         move (cstring(mid(l_sData,l_iDataSize,1))) to l_sData\r
1716         \r
1717         function_return l_sData\r
1718     end_function\r
1719     \r
1720     function encrypt string in_data returns string\r
1721         local string l_sData\r
1722         \r
1723         get encrypt_decrypt in_data 0 to l_sData\r
1724         function_return l_sData\r
1725     end_function\r
1726     \r
1727     function decrypt string in_data returns string\r
1728         local string l_sData\r
1729         \r
1730         get encrypt_decrypt in_data 1 to l_sData\r
1731         function_return l_sData\r
1732     end_function\r
1733     \r
1734     procedure destroy_key\r
1735         local integer l_iResult\r
1736         local handle l_hKey l_hHash\r
1737         \r
1738         get c_hKey to l_hKey\r
1739         \r
1740         if (l_hKey <> 0) begin\r
1741             move (CryptDestroyKey(l_hKey)) to l_iResult     \r
1742             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1743                 showln "ERROR: CryptDestroyKey " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))                      \r
1744             end  \r
1745             else begin\r
1746                 set c_hKey to 0\r
1747                 set c_sAlg to ""\r
1748             end\r
1749         end\r
1750         \r
1751         get c_hHash to l_hHash\r
1752         if (l_hHash <> 0) send destroy_hash        \r
1753         \r
1754     end_procedure\r
1755     \r
1756     procedure release_context\r
1757         local integer l_iResult\r
1758         local handle l_hProv  \r
1759         \r
1760         get c_hProv to l_hProv\r
1761     \r
1762         if (l_hProv <> 0) begin    \r
1763             move (CryptReleaseContext(l_hProv, 0)) to l_iResult\r
1764             if ((l_iResult <> 1) and (GetLastError() <> 0)) begin\r
1765                 showln "ERROR: Cryptrelease_context " l_iResult " - " (GetLastError()) " - " (get_last_error_detail(GetLastError()))\r
1766             end    \r
1767             else set c_hProv to 0\r
1768         end\r
1769         \r
1770     end_procedure\r
1771     \r
1772     procedure destory_object\r
1773         local handle l_hProv l_hHash l_hKey\r
1774         \r
1775         get c_hKey to l_hKey\r
1776         if (l_hKey <> 0) send destroy_key\r
1777         \r
1778         get c_hHash to l_hHash\r
1779         if (l_hHash <> 0) send destroy_hash\r
1780         \r
1781         get c_hProv to l_hProv\r
1782         if (l_hProv <> 0) send release_context\r
1783              \r
1784         forward send destory_object\r
1785     end_procedure\r
1786         \r
1787 end_class\r
1788 \r
1789 //-------------------------------------------------------------------------\r
1790 // Functions\r
1791 //-------------------------------------------------------------------------\r
1792 \r
1793 // Used for procedural invocations of hashing and encrypting\r
1794 object msAdvCrypt_global_obj is an msAdvCrypt\r
1795 end_object\r
1796 \r
1797 // Procedural one-shot use of msAdvCrypt hashing\r
1798 function msAdvCrypt_hash global string in_data string in_hash returns string\r
1799     local string l_sReturn\r
1800    \r
1801     send aquire_context to msAdvCrypt_global_obj\r
1802     get make_hash of msAdvCrypt_global_obj in_data in_hash to l_sReturn\r
1803     send destroy_hash to msAdvCrypt_global_obj\r
1804     send release_context to msAdvCrypt_global_obj\r
1805     \r
1806     function_return l_sReturn\r
1807 end_function\r
1808 \r
1809 function sha512_hex global string in_data returns string\r
1810     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'HEX'))\r
1811 end_function\r
1812 \r
1813 function sha512_base64 global string in_data returns string\r
1814     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA512"),'BASE64'))\r
1815 end_function\r
1816 \r
1817 function sha384_hex global string in_data returns string\r
1818     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'HEX'))\r
1819 end_function\r
1820 \r
1821 function sha384_base64 global string in_data returns string\r
1822     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA384"),'BASE64'))\r
1823 end_function\r
1824 \r
1825 function sha256_hex global string in_data returns string\r
1826     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'HEX'))\r
1827 end_function\r
1828 \r
1829 function sha256_base64 global string in_data returns string\r
1830     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA256"),'BASE64'))\r
1831 end_function\r
1832 \r
1833 function sha1_hex global string in_data returns string\r
1834     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'HEX'))\r
1835 end_function\r
1836 \r
1837 function sha1_base64 global string in_data returns string\r
1838     function_return (binary_to_string(msAdvCrypt_hash(in_data, "SHA1"),'BASE64'))\r
1839 end_function\r
1840 \r
1841 function md5_hex global string in_data returns string\r
1842     function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'HEX'))\r
1843 end_function\r
1844 \r
1845 function md5_base64 global string in_data returns string\r
1846     function_return (binary_to_string(msAdvCrypt_hash(in_data, "MD5"),'BASE64'))\r
1847 end_function\r
1848 \r
1849 // Procedural one-shot use of msAdvCrypt AES256 encryption (HEX)\r
1850 function aes256_hex_enc global string in_data string in_key returns string\r
1851     local string l_sReturn l_sBuf\r
1852    \r
1853     send aquire_context to msAdvCrypt_global_obj\r
1854     \r
1855     send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"\r
1856     send modify_key_mode to msAdvCrypt_global_obj "CBC"\r
1857     \r
1858     get generate_random_key_iv of msAdvCrypt_global_obj to l_sBuf    \r
1859     move l_sBuf to l_sReturn\r
1860     \r
1861     get encrypt of msAdvCrypt_global_obj in_data to l_sBuf\r
1862     append l_sReturn l_sBuf\r
1863     \r
1864     send destroy_key to msAdvCrypt_global_obj    \r
1865     send release_context to msAdvCrypt_global_obj\r
1866     \r
1867     function_return (binary_to_string(l_sReturn,"HEX"))\r
1868 end_function\r
1869 \r
1870 // Procedural one-shot use of msAdvCrypt AES256 decryption (HEX)\r
1871 function aes256_hex_dec global string in_data string in_key returns string\r
1872     local string l_sReturn l_sBuf\r
1873    \r
1874     move (string_to_binary(in_data,"HEX")) to l_sBuf\r
1875    \r
1876     send aquire_context to msAdvCrypt_global_obj    \r
1877     send derive_key to msAdvCrypt_global_obj in_key "SHA256" "AES_256"\r
1878     send modify_key_mode to msAdvCrypt_global_obj "CBC"\r
1879     \r
1880     send modify_key_iv to msAdvCrypt_global_obj (mid(l_sBuf,16,1))\r
1881     \r
1882     get decrypt of msAdvCrypt_global_obj (mid(l_sBuf,length(l_sBuf)-16,17)) to l_sReturn\r
1883     \r
1884     send destroy_key to msAdvCrypt_global_obj    \r
1885     send release_context to msAdvCrypt_global_obj\r
1886     \r
1887     function_return l_sReturn\r
1888 end_function\r