Option Strict On 'Original: ' February 23, 2009 ' https://searchcode.com/codesearch/view/9497495/ 'This Code: ' April 12, 2017 ' Orator / 魔界の仮面弁士 ' http://www.vb-user.net/junk/replySamples/2017.04.12.20.39/FileSystemCache.txt Imports System Imports System.Collections.Generic Imports System.ComponentModel Imports System.Data Imports System.Diagnostics Imports System.Runtime.InteropServices Imports System.Security.Principal #If USE_ANALYSIS_SERVICES Then Imports Microsoft.AnalysisServices.AdomdServer #End If Module FileSystemCache Public Sub ClearFileSystemCache(Optional clearStandbyCache As Boolean = True) SetIncreasePrivilege(SE_INCREASE_QUOTA_NAME) If IntPtr.Size = 8 Then SetSystemInfo(SystemInformationClass.FileCache, New SYSTEM_CACHE_INFORMATION_64() With {.MinimumWorkingSet = -1, .MaximumWorkingSet = -1}) Else SetSystemInfo(SystemInformationClass.FileCache, New SYSTEM_CACHE_INFORMATION_32() With {.MinimumWorkingSet = UInteger.MaxValue, .MaximumWorkingSet = UInteger.MaxValue}) End If If clearStandbyCache Then SetIncreasePrivilege(SE_PROFILE_SINGLE_PROCESS_NAME) Try SetSystemInfo(SystemInformationClass.MemoryList, ClearStandbyPageList) Catch ex As Exception ClearStandbyFileSystemCacheByConsumingAvailableMemory() End Try End If End Sub #If USE_ANALYSIS_SERVICES Then Public Sub ClearAllCaches() Dim xmla As New XmlaDiscover() xmla.ClearCache() ClearFileSystemCache(True) End Sub #End If Private Sub SetSystemInfo(Of T As Structure)(sysInfoCls As SystemInformationClass, ByRef info As T) Dim sz As Integer = Marshal.SizeOf(info) Dim gch As GCHandle = GCHandle.Alloc(info, GCHandleType.Pinned) Dim result As Integer = NtSetSystemInformation(sysInfoCls, gch.AddrOfPinnedObject(), sz) Dim win32Error As Integer = Marshal.GetLastWin32Error() gch.Free() If result <> 0 Then Throw NewWin32Exception(win32Error, String.Format("0x{0:X8} : NtSetSystemInformation({1})", result, sysInfoCls)) End If End Sub Private Sub ClearStandbyFileSystemCacheByConsumingAvailableMemory() Dim sysinfo As New SYSTEM_INFO() GetSystemInfo(sysinfo) My.Application.Log.TraceSource.TraceInformation("Page size:{0:#,0} Bytes", sysinfo.dwPageSize) Using pcAvailableBytes As New PerformanceCounter("Memory", "Available Bytes", True) Dim lngAvailableBytes As Long = CLng(pcAvailableBytes.NextValue()) My.Application.Log.TraceSource.TraceInformation("Available Bytes after clearing active cache: {0:#,0}", lngAvailableBytes) Dim lngRemainingBytes As Long = lngAvailableBytes - (1024 * 1024) Dim listPtrMem As New List(Of IntPtr)() Try My.Application.Log.TraceSource.TraceInformation("Preparing to consume {0:#,0} bytes of memory", lngRemainingBytes) While lngRemainingBytes > 0 Dim iAllocLen As Integer = CInt(Math.Min(Convert.ToInt64(sysinfo.dwPageSize * 1024), lngRemainingBytes)) lngRemainingBytes -= iAllocLen listPtrMem.Add(Marshal.AllocHGlobal(iAllocLen)) For j = 0 To iAllocLen - 1 Step CInt(sysinfo.dwPageSize) Marshal.WriteByte(listPtrMem(listPtrMem.Count - 1), j, CByte(1)) Next End While lngAvailableBytes = CLng(pcAvailableBytes.NextValue()) My.Application.Log.TraceSource.TraceInformation("Available Bytes after consuming memory: {0:#,0}", lngAvailableBytes) Catch ex As OutOfMemoryException My.Application.Log.TraceSource.TraceInformation("Received OutOfMemoryException: " & ex.Message) My.Application.Log.TraceSource.TraceInformation("Was able to consume desired memory except for the following number of bytes: {0:#,0}", lngRemainingBytes) Finally For Each ptrMem In listPtrMem If ptrMem <> IntPtr.Zero Then Marshal.FreeHGlobal(ptrMem) End If Next End Try lngAvailableBytes = CLng(pcAvailableBytes.NextValue()) My.Application.Log.TraceSource.TraceInformation("Available Bytes after freeing consumed memory: {0:#,0}", lngAvailableBytes) pcAvailableBytes.Close() End Using End Sub Public Function GetFileSystemCacheBytes() As DataTable Dim fltCacheBytes, fltCacheBytesPeak, fltStandbyCacheBytes? As Single Using pcCacheBytes As New PerformanceCounter("Memory", "Cache Bytes", True), pcCacheBytesPeak As New PerformanceCounter("Memory", "Cache Bytes Peak", True) fltCacheBytes = pcCacheBytes.NextValue() fltCacheBytesPeak = pcCacheBytesPeak.NextValue() fltStandbyCacheBytes = Nothing Try Using pcStandbyCacheBytes As New PerformanceCounter("Memory", "Standby Cache Normal Priority Bytes", True) fltStandbyCacheBytes = pcStandbyCacheBytes.NextValue() pcStandbyCacheBytes.Close() End Using Catch End Try pcCacheBytes.Close() pcCacheBytesPeak.Close() End Using Dim tbl As New DataTable("FileSystemCacheInfo") With tbl.Columns .Add("Cache Bytes", GetType(Long)).AllowDBNull = False .Add("Cache Bytes Peak", GetType(Long)).AllowDBNull = False .Add("Standby Cache Bytes", GetType(Long)).AllowDBNull = True End With tbl.Rows.Add( CLng(fltCacheBytes), CLng(fltCacheBytesPeak), If(Not fltStandbyCacheBytes.HasValue, New Long?(), CLng(fltStandbyCacheBytes)) ) Return tbl End Function Private Structure SYSTEM_CACHE_INFORMATION_32 Public CurrentSize As UInteger Public PeakSize As UInteger Public PageFaultCount As UInteger Public MinimumWorkingSet As UInteger Public MaximumWorkingSet As UInteger Public Unused1 As UInteger Public Unused2 As UInteger Public Unused3 As UInteger Public Unused4 As UInteger End Structure Private Structure SYSTEM_CACHE_INFORMATION_64 Public CurrentSize As Long Public PeakSize As Long Public PageFaultCount As Long Public MinimumWorkingSet As Long Public MaximumWorkingSet As Long Public Unused1 As Long Public Unused2 As Long Public Unused3 As Long Public Unused4 As Long End Structure Private Declare Unicode Sub GetSystemInfo Lib "kernel32" (ByRef lpSystemInfo As SYSTEM_INFO) Private Structure _PROCESSOR_INFO_UNION Friend dwOemId As UInteger Friend wProcessorArchitecture As UShort Friend wReserved As UShort End Structure Private Structure SYSTEM_INFO Friend uProcessorInfo As _PROCESSOR_INFO_UNION Public dwPageSize As UInteger Public lpMinimumApplicationAddress As IntPtr Public lpMaximumApplicationAddress As IntPtr Public dwActiveProcessorMask As IntPtr Public dwNumberOfProcessors As UInteger Public dwProcessorType As UInteger Public dwAllocationGranularity As UInteger Public dwProcessorLevel As UShort Public dwProcessorRevision As UShort End Structure Private Declare Unicode Function NtSetSystemInformation Lib "ntdll" (ByVal SystemInformationClass As SystemInformationClass, SystemInfo As IntPtr, SystemInfoLength As Integer) As Integer Private Enum SystemInformationClass As Integer Basic = 0 Processor = 1 Performance = 2 TimeOfDay = 3 Path = 4 Process = 5 ProcessesAndThreads = 5 CallCounts = 6 Device = 7 ProcessorPerformance = 8 ProcessorTimes = 8 Flags = 9 GlobalFlag = 9 CallTime = 10 [Module] = 11 Lock = 12 StackTrace = 13 PagedPool = 14 NonPagedPool = 15 Handle = 16 [Object] = 17 PageFile = 18 InstructionEmulationCounts = 19 VdmBop = 20 FileCache = 21 PoolTag = 22 ProcessorStatistics = 23 DpcBehaviour = 24 FullMemory = 25 LoadImage = 26 UnloadImage = 27 TimeAdjustment = 28 SummaryMemory = 29 NextEventId = 30 EventIds = 31 CrashDump = 32 Exception = 33 CrashDumpState = 34 KernelDebugger = 35 ContextSwitch = 36 RegistryQuota = 37 LoadAndCallImage = 38 PrioritySeparation = 39 PlugPlayBus = 40 Dock = 41 REM 42 ProcessorSpeed = 43 REM 43 CurrentTimeZone = 44 TimeZone = 44 Lookaside = 45 SetTimeSlipEvent = 46 CreateSession = 47 DeleteSession = 48 REM 49 RangeStart = 50 Verifier = 51 AddVerifier = 52 SessionProcesses = 53 REM 54-79 MemoryList = 80 End Enum 'SystemInfo Private Const ClearStandbyPageList As Integer = 4 Private Declare Unicode Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueW" (host As String, name As String, ByRef pluid As Long) As Boolean Private Declare Unicode Function AdjustTokenPrivileges Lib "advapi32" (htok As IntPtr, disall As Boolean, ByRef newst As TokPriv1Luid, len As Integer, prev As IntPtr, relen As IntPtr) As Boolean Private Const SE_PRIVILEGE_ENABLED As Integer = &H2 Private Const TOKEN_QUERY As Integer = &H8 Private Const TOKEN_ADJUST_PRIVILEGES As Integer = &H20 Private Const SE_INCREASE_QUOTA_NAME As String = "SeIncreaseQuotaPrivilege" Private Const SE_PROFILE_SINGLE_PROCESS_NAME As String = "SeProfileSingleProcessPrivilege" Private Structure TokPriv1Luid Public Count As Integer Public Luid As Long Public Attr As Integer End Structure Private Sub SetIncreasePrivilege(privilegeName As String) Using currentIdentity As WindowsIdentity = WindowsIdentity.GetCurrent(TokenAccessLevels.AdjustPrivileges Or TokenAccessLevels.Query) Dim win32Error As Integer Dim tp As New TokPriv1Luid() With {.Count = 1, .Luid = 0, .Attr = SE_PRIVILEGE_ENABLED} If Not LookupPrivilegeValue(Nothing, privilegeName, tp.Luid) Then win32Error = Marshal.GetLastWin32Error() Throw NewWin32Exception(win32Error, "LookupPrivilegeValue(""" & privilegeName & """)") End If If Not AdjustTokenPrivileges(currentIdentity.Token, False, tp, 0, IntPtr.Zero, IntPtr.Zero) Then win32Error = Marshal.GetLastWin32Error() Throw NewWin32Exception(win32Error, "AdjustTokenPrivileges(" & currentIdentity.Name & ")") End If End Using End Sub Private Function NewWin32Exception(win32Error As Integer, addtionalMessage As String) As Win32Exception Dim ex As New Win32Exception(win32Error) Try My.Application.Log.WriteException(ex, TraceEventType.Error, addtionalMessage) Catch End Try Return New Win32Exception(ex.ErrorCode, ex.Message & If(String.IsNullOrEmpty(addtionalMessage), "", vbCrLf & addtionalMessage)) End Function End Module