------------------------------------------------------------------------ -- Copyright (C) 2018 Daniil Baturin -- -- This file is part of hvinfo. -- -- hvinfo is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 2 of the License, or -- (at your option) any later version. -- -- hvinfo is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with hvinfo. If not, see . ------------------------------------------------------------------------ package body Hypervisor_Check is function CPUID (Arg : Unsigned_32) return CPUID_Registers is eax, ebx, ecx, edx : Unsigned_32; begin #if X86 then Asm("cpuid", Outputs => (Unsigned_32'Asm_Output ("=a", eax), Unsigned_32'Asm_Output ("=b", ebx), Unsigned_32'Asm_Output ("=c", ecx), Unsigned_32'Asm_Output ("=d", edx)), Inputs => Unsigned_32'Asm_Input ("a", Arg)); return (eax, ebx, ecx, edx); #else return (0, 0, 0, 0); #end if; end CPUID; -- Convert an unsigned 32-bit integer to a string of 4 characters function String_of_U32 (Arg : Unsigned_32) return US.Unbounded_String is Word : Unsigned_32; Result : US.Unbounded_String; begin Word := Arg; while Word > 0 loop US.Append (Result, Character'Val (Word and 16#FF#)); Word := Shift_Right (Word, 8); end loop; return Result; end String_of_U32; function Contains (Haystack : US.Unbounded_String; Needle : String) return Boolean is Position : Natural; begin Position := US.Index (Source => Haystack, Pattern => Needle); if Position > 0 then return True; else return False; end if; end Contains; -- Read the first line of file, return empty string in case of errors -- Pretty much what we need for reading /proc files etc. function Head_Of_File (Path : String) return US.Unbounded_String is File : IO.File_Type; Result : US.Unbounded_String; begin IO.Open (File => File, Name => Path, Mode => IO.In_File); UIO.Get_Line (File, Result); IO.Close(File); return Result; exception when others => return US.To_Unbounded_String (""); end Head_Of_File; -- Xen support hardware and paravirtual modes, in paravirtual mode -- it's not detectable with CPUID function Xen_Present return Boolean is begin if Config.Linux then if Contains (Head_Of_File (Linux_Sys_HV_Type_File), "xen") then return True; else return False; end if; elsif Config.FreeBSD then return Command_Succeeds (FreeBSD_Xen_Present_Command); else raise OS_Not_Supported; end if; end Xen_Present; -- Hypervisors should set the bit 31 of %ecx to 1 in CPUID leaf 1 function Hypervisor_Present return Boolean is Registers : CPUID_Registers; begin Registers := CPUID (1); if (((Shift_Right (Registers(3), 31)) and 1) = 1) then return True; else return False; end if; end Hypervisor_Present; -- Execute a system command and return true if it succeeded -- (i.e. returned 0) function Command_Succeeds (Command : String) return Boolean is use Interfaces.C; function Sys (Arg : Char_Array) return Integer; pragma Import (C, Sys, "system"); Ret_Val : Integer; begin Ret_Val := Sys (Interfaces.C.To_C (Command)); if Ret_Val > 0 then return False; else return True; end if; end Command_Succeeds; -- Calling CPUID instruction with hypervisor leaf in %eax -- puts the vendor string in %ebx, %ecx, and %edx function Get_Vendor_String return US.Unbounded_String is use US; Vendor_String : US.Unbounded_String; Registers : CPUID_Registers; begin Registers := CPUID (Hypervisor_Leaf); Vendor_String := String_of_U32 (Registers(2)) & String_of_U32 (Registers(3)) & String_of_U32 (Registers(4)); return Vendor_String; end Get_Vendor_String; function Get_Vendor_Name return US.Unbounded_String is use US; Vendor_String, Vendor_Name : Unbounded_String; begin Vendor_String := Get_Vendor_String; if Vendor_String = "KVMKVMKVM" then Vendor_Name := To_Unbounded_String (KVM); elsif Vendor_String = "TCGTCGTCGTCG" then Vendor_Name := To_Unbounded_String (QEMU); elsif Vendor_String = "XenVMMXenVMM" then Vendor_Name := To_Unbounded_String (Xen_HVM); elsif Vendor_String = "VMwareVMware" then Vendor_Name := To_Unbounded_String (VMware); elsif Vendor_String = "Microsoft Hv" then Vendor_Name := To_Unbounded_String (HyperV); elsif Vendor_String = "bhyve bhyve " then Vendor_Name := To_Unbounded_String (bhyve); else Vendor_Name := To_Unbounded_String ("Unknown hypervisor"); end if; return Vendor_Name; end Get_Vendor_Name; -- There are two cases: 1. DMI is not available on a _system_ -- (paravirtualized guests are notable examples) -- 2. the OS doesn't have a DMI API available to unprivileged users function DMI_Available return Boolean is begin if Config.Linux then -- Linux provides DMI info via sysfs, but on systems -- without SMBIOS it's not available if Ada.Directories.Exists ("/sys/class/dmi") then return True; else return False; end if; else -- Other OSes don't have DMI API we can use return False; end if; end DMI_Available; function Get_DMI_Vendor_String return US.Unbounded_String is Name : US.Unbounded_String; begin if Config.Linux then Name := Head_Of_File (Linux_Sys_Vendor_File); else raise OS_Not_Supported; end if; return Name; end Get_DMI_Vendor_String; function Get_DMI_Product_Name return US.Unbounded_String is Product_Name, Vendor_Name : US.Unbounded_String; begin if Config.Linux then Product_Name := Head_Of_File (Linux_Sys_Product_File); else raise OS_Not_Supported; end if; if Contains (Product_Name, KVM_DMI_Pattern) then Vendor_Name := US.To_Unbounded_String (KVM); else Vendor_Name := US.Null_Unbounded_String; end if; return Vendor_Name; end Get_DMI_Product_Name; function Get_DMI_Vendor_Name (Vendor_String : US.Unbounded_String) return US.Unbounded_String is Vendor_Name : US.Unbounded_String; begin if Contains (Vendor_String, VMWare_DMI_Pattern) then Vendor_Name := US.To_Unbounded_String (VMWare); elsif Contains (Vendor_String, HyperV_DMI_Pattern) then Vendor_Name := US.To_Unbounded_String (HyperV); elsif Contains (Vendor_String, VirtualBox_DMI_Pattern) then Vendor_Name := US.To_Unbounded_String (VirtualBox); elsif Contains (Vendor_String, Parallels_DMI_Pattern) then Vendor_Name := US.To_Unbounded_String (Parallels); elsif Contains (Vendor_String, QEMU_DMI_Pattern) then Vendor_Name := US.To_Unbounded_String (QEMU); else Vendor_Name := US.Null_Unbounded_String; end if; return Vendor_Name; end Get_DMI_Vendor_Name; function VirtualBox_PCI_Present return Boolean is begin if Config.FreeBSD then if Command_Succeeds ("/sbin/sysctl dev.vgapci | grep vendor=0x80ee > /dev/null") then return True; else return False; end if; elsif Config.Linux then -- Can be done, but on Linux VirtualBox is covered by DMI checks, -- so I cut the corners here -- XXX: maybe it's relevant on some UEFI machines return False; else return False; end if; end; end Hypervisor_Check;