unit smbios;
{$IFDEF FPC}{$CALLING OLDFPCCALL}{$ENDIF}
{Jednotka ke cteni informaci o hardwaru pocitace (predevsim o BIOSu a zdrojich
 zakladni desky). Vyuziva rozhrani SMBIOS a vetsinou predpoklada verzi
 alespon 2.1. Zpristupnuje ale i nektere funkce verzi 2.3 a 2.5.
 Jednotka je obojzivelna - lze ji pouzivat jak s Turbo pascalem, tak s
 Freepascalem.}
interface

type
   P_SMBIOS = ^T_SMBIOS;
   T_SMBIOS = object
   header:pchar;
   headersize:word;
   data:pchar;
   datasize:word;
   found:boolean;
   header_position_in_segment:word;
   table:pointer;

   {-------------- Obecne funkce ----------------}
   Function Init:boolean;
   Function Get_SMBIOS_version:string;
   Function Get_Max_Item_Size:word;
   Function Get_Data_Size:word;
   Function Get_Data_address:longint;
   Function Get_Number_of_structures:word;
   Function Data_Position(n:word):word;
   Function Data_Type(n:word):byte;
   Function Data_Formated_Length(n:word):byte;
   Function Data_Num_of_strings(n:word):byte;
   Function Data_Get_String(n:word;i:byte):string;
   Function Num_of_specified_tables(typ:byte):byte;
   Function Find_specified_table(typ,num:byte):word;

   Function Device_String_From_Table(typ,e,n:byte):string;
   Function Device_Byte_From_Table(typ,e,n:byte):byte;
   Function Device_Word_From_Table(typ,e,n:byte):word;
   Procedure Done;
   {---------------------------------------------}

   {------------- Specificke funkce -------------}
   Function BIOS_vendor:string;
   Function BIOS_version:string;
   Function BIOS_date:string;

   Function System_vendor:string;
   Function System_product:string;
   Function System_version:string;
   Function System_serial:string;

   Function Board_vendor:string;
   Function Board_product:string;
   Function Board_version:string;
   Function Board_serial:string;

   Function ProcSocket_Num_of_sockets:byte;
   Function ProcSocket_vendor(n:byte):string;  {Tyka se procesorovych patic,}
   Function ProcSocket_product(n:byte):string; {ktere mohou a nemusi byt}
   Function ProcSocket_socket(n:byte):string;  {osazeny procesorem ci koprem}
   Function ProcSocketMaxSpeed(n:byte):word;   {max. podporovana rychlost}

   Function Proc_Num_of_Installed_CPUs:byte;
   Function Proc_Is_CPU(n:byte):boolean;
   Function ProcNum_into_SocketNum(n:byte):byte;

   Function Proc_vendor(n:byte):string;   {Tyka se}
   Function Proc_product(n:byte):string;  {realne osazenych}
   Function Proc_socket(n:byte):string;   {procesoru typu CPU}
   Function ProcSpeed(n:byte):word;       {aktualni rychlost procesoru}
   Function Proc_Num_of_All_cores(n:byte):string;
   Function Proc_Num_of_Enabled_cores(n:byte):string;

   Function Memory_Total_Size:longint;    {velikost pameti v megabajtech}
   Function Mem_Num_of_slots:byte;        {pocet pametovych slotu}
   Function Mem_Speed(n:byte):word;       {aktualni rychlost modulu v Ns}
   Function Mem_Module_Size_KB(n:byte):longint;
   Function Mem_Module_Size_MB(n:byte):word;
   Function Mem_Vendor(n:byte):string;
   Function Mem_Type(n:byte):string;

   Function PointDev_Type:string;
   Function PointDev_Interface:string;
   Function PointDev_Num_of_Buttons:byte;

   Function Enclosure_type:string;

   Function Boot_Status:byte;
   end;

   TOROM = object
   amount:byte;
   table:pointer;
   Function Init:boolean;
   Function GetSeg(num:byte):word;
   Function GetOfs(num:byte):word;
   Function GetLen(num:byte):word;
   Function IsPCI(num:byte):boolean;
   Function Vendor_id(num:byte):word;
   Function Device_id(num:byte):word;
   Function Class(num:byte):word;
   Function Subclass(num:byte):word;
   Function Interf(num:byte):word;
   Function LoadOROM(num:byte):pointer;
   Procedure Done;
   end;

   TPNP_BIOS = object
   found:boolean;
   pnp_segment:word;
   pnp_offset:longint;
   header_data:array[0..35] of byte;
   fnc_arg:array[0..7,0..1] of longint;
   entrypoint:pointer;
   nodesize,numnodes:word;
   devbuf:pointer;
   Procedure Init;

   Function Get_Number_of_device_nodes:word;
   Function Get_Size_of_device_nodes:word;
   Function Get_Device_Info_Buffer(dev:byte):byte;
   Function Get_Configuration_Event(var w:word):byte;
   Function Get_ISA_Configuration_Structure:byte;
   Function LastDev_size:word;
   Function LastDev_handlenumber:byte;
   Function LastDev_identifier:string;
   Function LastDev_serialnum:string;

   Function Get_ISA_Configuration__dataport:word;
   Function Get_ISA_Configuration__CarSelNum:byte;

   Function InternalCallFunc(func:word;words_2_stack:byte):word;
   Procedure Internal_Get_Number_and_size_of_device_nodes(var ns,nd:word);
   Procedure Done;
   end;

const SMB_BIOS         = 0;
      SMB_syst         = 1;
      SMB_board        = 2;
      SMB_enclosure    = 3;
      SMB_proc         = 4;
      SMB_mem_obsolete = 5;
      SMB_mem_mod_obsol= 6;
      SMB_cache        = 7;
      SMB_port         = 8;
      SMB_slot         = 9;
      SMB_onboard      = 10;
      SMB_OEM_strings  = 11;
      SMB_syscfg       = 12;
      SMB_bioslang     = 13;
      SMB_syseventlog  = 15;
      SMB_mem_array    = 16;
      SMB_mem_dev      = 17;
      SMB_pointdev     = 21;

      proc_CPU   = 3;
      proc_MATH  = 4;
      proc_DSP   = 5;
      proc_video = 6;


{--------------------------------------------------------------------------}
implementation
{$IFDEF FPC}uses go32;{$ENDIF}

const MAX_OROM = 10;
      HexDigits:array[0..15] of char = '0123456789ABCDEF';

type Tsecpole = array[1..512] of word;
     Psecpole = ^Tsecpole;

     TOROM_rec = packed record
       segm:word;
       offs:word;
       len:word;
       is_pci:boolean;
       vendor_id:word;
       device_id:word;
       class:byte;
       subclass:byte;
       interf:byte;
       end;

     TOROM_pole = array[1..MAX_OROM] of TOROM_rec;
     POROM_pole = ^TOROM_pole;

     PPNP_rec = ^TPNP_rec;
     TPNP_rec = packed record
       {0}  magic:array[0..3] of char;        { $PnP }
       {4}  version:byte;
       {5}  length:byte;
       {6}  control_field:word;
       {8}  checksum:byte;
       {9}  event_not_flg_addr:longint;
       {13} rm_16_offs:word;
       {15} rm_16_segm:word;
       {17} pm_16_offs:word;
       {19} pm_16_segm_base:longint;
       {23} oem_dev_id:longint;
       {27} rm_16_segm_ds:word;
       {29} pm_16_segm_base_ds:longint;
       end;

    const
    PNP_arg_type_1 = 1;   {v nizsim wordu bude proste cislo}
    PNP_arg_type_2 = 2;   {segment na promennou typu DWORD}
    PNP_arg_type_3 = 3;   {offset na promennou typu DWORD}
    PNP_arg_type_4 = 4;   {segment na buffer}
    PNP_arg_type_5 = 5;   {offset na buffer}


{$IFDEF FPC}
Function MemB(segm,offs:word):byte;assembler;
asm
movzx ebx,segm
shl ebx,4
movzx eax,offs
add ebx,eax
mov al,fs:[ebx]
end;
{$ELSE}
Function MemB(segm,offs:word):byte;
begin
MemB:=Mem[segm:offs];
end;
{$ENDIF}


Function RMString(segm,offs:word;len:byte):string;
var a:longint;
    s:string;
begin
s:='';
for a:=0 to len-1 do s:=s+char(MemB(segm,offs+a));
RMstring:=s;
end;


Function StrPas(p:pchar):string;
{Provede konverzi z PCharu na pascalovsky string}
var a:byte;
    s:string;
    c:char;
begin
for a:=0 to 255 do
    begin
    c:=p[a];
    if c<>#0 then s[a+1]:=c
       else begin
       s[0]:=char(a);
       StrPas:=s;
       Exit;
       end;
    end;
s[0]:=#255;
StrPas:=s;
end;


Function Mocn2(x:byte):word;
{Vytvori mocninu 2 na X-tou}
var aa:byte;
    mm:word;
begin
mm:=1;
for aa:=1 to x do mm:=mm*2;
Mocn2:=mm;
end;


Function SwapString(s:string):string;
var a,b:byte;
      t:string;
begin
a:=Length(s);
t:='';
for b:=a downto 1 do t:=t+s[b];
SwapString:=t;
end;

Function HexStr(l:longint):string;
var a:longint;
    s:string;
begin
s:='';
a:=0;
repeat
s:=s+HexDigits[l and 15];
l:=l div 16;
inc(a);
until l=0;
HexStr:=SwapString(s);
end;



Function ProhledejSegment(segm:word;var offs:longint;limit:word;gran:word;const retezec:string):boolean;
var l:byte;
begin
l:=Length(retezec);
repeat
  if RMstring(segm,offs,l)=retezec then
     begin
     ProhledejSegment:=true;
     Exit;
     end;
  inc(offs,gran);
until offs>limit-gran;
offs:=0;
ProhledejSegment:=false;
end;


function MyVal (S: string): longint;
var pom1,pom2 : Integer;
begin
Val (S, Pom1, Pom2);
MyVal := Pom1;
end;

function MyStr (Cislo: longint): string;
var Vysledek : string;
begin
Str (Cislo, Vysledek);
MyStr := Vysledek;
end;


Function T_SMBIOS.Init:boolean;
{Nacte blok dat SMBIOS a pripravi vsechny potrebne tabulky}
var b,c,checksum:word;
    ok:boolean;
    a:longint;
    adr,n:longint;
    pole:psecpole;

begin
header:=nil;
data:=nil;
table:=nil;
found:=false;
Init:=false;
ok:=false;
a:=0;
repeat
if ProhledejSegment($F000,a,65535,16,'_SM_') then
   begin
   headersize:=MemB($F000,a+5);
   if headersize>8 then  {ve skutecnosti by melo byt 1Fh}
      begin
      checksum:=0;
      for b:=0 to headersize-1 do inc(checksum,MemB($F000,a+b));
      if (checksum mod 256)=0 then ok:=true;
      end;
   end
   else Exit;
if ok=false then inc(a,16);
until ok=true;

{Mame nalezeny a potvrzeny blok SMBIOSu}
GetMem(header,headersize);
{$IFDEF FPC}
seg_move(Segment_To_Descriptor($F000), a, get_ds, longint(header),headersize);
{$ELSE}
Move(Ptr($F000,a)^,header^,headersize);
{$ENDIF}
header_position_in_segment:=a;
found:=true;
Init:=true;

datasize:=Get_Data_Size;
adr:=Get_Data_Address;
GetMem(data,datasize);
{$IFDEF FPC}
seg_move(Segment_To_Descriptor(adr div 16), adr mod 16, get_ds, longint(data),datasize);
{$ELSE}
Move(ptr(adr div 16,adr mod 16)^,data^,datasize);
{$ENDIF}

n:=Get_Number_of_structures;
GetMem(pole,n);
table:=pole;

{Ted vytvorim tabulku odkazy na jednotlive polozky SMBIOS zaznamu}
ok:=false;
b:=0;
a:=1;
pole^[a]:=0;

repeat
c:=byte(data[b+1]);   {velikost formatovane casti polozky}
inc(b,c);

{ted jsem preskocil formatovanou cast polozky a budu zpracovavat retezce}
while (data[b]<>#0) or (data[b+1]<>#0) do
      if (b<=datasize) then inc(b) else ok:=true;

if ok=false then
   begin
   inc(b,2);
   if a<n then begin inc(a);pole^[a]:=b;end else ok:=true;
   end;
until ok=true;
end;


Function T_SMBIOS.Get_SMBIOS_version:string;
{Verze SMBIOS, napr. 2.3}
begin
if found
   then Get_SMBIOS_version:=MyStr(byte(header[6]))+'.'+MyStr(byte(header[7]))
   else Get_SMBIOS_version:='0.0';
end;


Function T_SMBIOS.Get_Max_Item_Size:word;
{Maximalni pouzita velikost tabulky zarizeni (formatovana cast + retezce)}
begin
if found then Get_Max_Item_size:=word(header[8])+word(header[9])*256
   else Get_Max_Item_size:=0;
end;


Function T_SMBIOS.Get_Data_Size:word;
{Celkova velikost vsech tabulek zarizeni dohromady}
begin
if found then Get_Data_size:=word(header[22])+word(header[23])*256
   else Get_Data_size:=0;
end;


Function T_SMBIOS.Get_Data_address:longint;
{Zjisti adresu bloku s tabulkami zarizeni}
var a:longint;
begin
if found then
   begin Move(header[24],a,4);Get_Data_address:=a;end
   else Get_Data_address:=0;
end;


Function T_SMBIOS.Get_Number_of_structures:word;
{Celkovy pocet tabulek zarizeni}
var a:longint;
begin
if found then Get_Number_of_structures:=word(header[28])+word(header[29])*256
   else Get_Number_of_structures:=0;
end;


Function T_SMBIOS.Data_Position(n:word):word;
{Pro zarizeni N najdi jeho tabulku dat}
var pole:psecpole;
    a:word;
begin
if not found then begin Data_Position:=65535;Exit;end;
if n>Get_Number_of_Structures then begin Data_Position:=65535;Exit;end;
pole:=table;
Data_Position:=pole^[n];
end;


Function T_SMBIOS.Data_Type(n:word):byte;
{U zarizeni N zjisti o jaky typ zarizeni jde}
var a:byte;
    w:word;
begin
w:=Data_Position(n);
if w=65535 then begin Data_Type:=255;Exit;end;
Data_Type:=byte(data[w+0]);
end;


Function T_SMBIOS.Data_Formated_Length(n:word):byte;
{Vrati delku formatovanych dat (t.j. bez retezcu) u zarizeni N.}
var a:byte;
    w:word;
begin
w:=Data_Position(n);
if w=65535 then begin Data_Formated_Length:=0;Exit;end;
Data_Formated_Length:=byte(data[w+1]);
end;


Function T_SMBIOS.Data_Num_of_strings(n:word):byte;
{Pocet retezcu u tabulky zarizni N.}
var a,o:byte;
    w,i:word;
begin
w:=Data_Position(n);
if w=65535 then begin Data_Num_of_strings:=0;Exit;end;
i:=byte(data[w+1]);
inc(w,i);
o:=0;
if (data[w]=#0) and (data[w+1]=#0) then begin Data_Num_of_strings:=0;Exit;end;
repeat
while (data[w]<>#0) do inc(w);
inc(o);
inc(w);
until data[w]=#0;
Data_Num_of_strings:=o;
end;


Function T_SMBIOS.Data_Get_String(n:word;i:byte):string;
{U tabulky zarizeni N vrati retezec cislo I}
var a,b,o:byte;
    w,c:word;
    p:pchar;
    s:string;
begin
if i=0 then begin Data_Get_String:='';Exit;end;
w:=Data_Position(n);
if w=65535 then begin Data_Get_String:='';Exit;end;

c:=byte(data[w+1]);
inc(w,c);
o:=0;
p:=data;

for b:=1 to i-1 do  {napred preskocime vsechny predesle retezce}
    begin
    while data[w]<>#0 do inc(w);
    inc(w);
    if data[w]=#0 then begin Data_Get_String:='';Exit;end;
    end;

inc(p,w);
s:=StrPas(p);
if s=' ' then s:='';
Data_Get_String:=s;
end;


Function T_SMBIOS.Device_String_From_Table(typ,e,n:byte):string;
{Najde zarizeni typu TYP, exemplare E a vrati retezec odkazovany z N-te
 pozice formatovaneho zahlavi}
var w,p:word;
    a:byte;
begin
w:=Find_Specified_Table(typ,e);
if w=0 then Device_String_From_Table:=''
   else begin
   p:=Data_position(w);
   a:=byte(data[p+n]);
   Device_String_From_Table:=Data_Get_String(w,a);
   end;
end;


Function T_SMBIOS.Device_Byte_From_Table(typ,e,n:byte):byte;
{Najde zarizeni typu TYP, exemplare E a vrati N-ty bajt formatovaneho zahlavi}
var w,p:word;
begin
w:=Find_Specified_Table(typ,e);
if w=0 then Device_Byte_From_Table:=255
   else begin
   p:=Data_position(w);
   Device_Byte_From_Table:=byte(data[p+n]);
   end;
end;


Function T_SMBIOS.Device_Word_From_Table(typ,e,n:byte):word;
{Najde zarizeni typu TYP, exemplare E a vrati N-ty word formatovaneho zahlavi}
var w,p:word;
    a:byte;
begin
w:=Find_Specified_Table(typ,e);
if w=0 then Device_Word_From_Table:=65535
   else begin
   p:=Data_position(w);
   Device_Word_From_Table:=word(data[p+n])+word(data[p+n+1])*256;
   end;
end;


Function T_SMBIOS.Num_of_specified_tables(typ:byte):byte;
{Zjisti, kolik zaznamu urciteho typu mame (napr. ke zjisteni poctu portu,
 slotu apod.)}
var a,b:byte;
begin
if found=false then begin Num_of_specified_tables:=0;Exit;end;
b:=0;
for a:=1 to Get_Number_of_structures do
    if Data_Type(a)=typ then inc(b);
Num_of_specified_tables:=b;
end;


Function T_SMBIOS.Find_specified_table(typ,num:byte):word;
{Vrati index tabulky zadaneho typu a exemplare}
var a,b:byte;
begin
if found=false then begin Find_specified_table:=0;Exit;end;
b:=1;
for a:=1 to Get_Number_of_structures do
    if Data_Type(a)=typ then
       if b=num then begin Find_specified_table:=a;Exit;end
                else inc(b);
Find_specified_table:=0;
end;


Procedure T_SMBIOS.Done;
{uvolni pametove bloky a uzavre objekt}
begin
if table<>nil then FreeMem(table,Get_number_of_structures);
if header<>nil then FreeMem(header,headersize);
if data<>nil then FreeMem(data,datasize);
end;


Function T_SMBIOS.BIOS_vendor:string;
{vyrobce BIOSu}
begin
BIOS_vendor:=Device_String_From_Table(0,1,4);
end;

Function T_SMBIOS.BIOS_version:string;
{verze BIOSu}
begin
BIOS_version:=Device_String_From_Table(0,1,5);
end;

Function T_SMBIOS.BIOS_date:string;
{datum BIOSu}
begin
BIOS_date:=Device_String_From_Table(0,1,8);
end;


Function T_SMBIOS.System_vendor:string;
{vyrobce pocitacoveho systemu}
begin
System_vendor:=Device_String_From_Table(1,1,4);
end;

Function T_SMBIOS.System_product:string;
{model pocitacoveho systemu}
begin
System_product:=Device_String_From_Table(1,1,5);
end;

Function T_SMBIOS.System_version:string;
{verze pocitacoveho systemu}
begin
System_version:=Device_String_From_Table(1,1,6);
end;

Function T_SMBIOS.System_serial:string;
{seriove cislo pocitace}
begin
System_serial:=Device_String_From_Table(1,1,7);
end;


Function T_SMBIOS.Board_vendor:string;
{vyrobce zakladni desky}
begin
Board_vendor:=Device_String_From_Table(2,1,4);
end;

Function T_SMBIOS.Board_product:string;
{model zakladni desky}
begin
Board_product:=Device_String_From_Table(2,1,5);
end;

Function T_SMBIOS.Board_version:string;
{verze zakladni desky}
begin
Board_version:=Device_String_From_Table(2,1,6);
end;

Function T_SMBIOS.Board_serial:string;
{seriove cislo zakladni desky}
begin
Board_serial:=Device_String_From_Table(2,1,7);
end;


Function T_SMBIOS.ProcSocket_Num_of_sockets:byte;
{pocet procesorovych patic na desce}
begin
ProcSocket_Num_of_sockets:=Num_of_specified_tables(4);
end;

Function T_SMBIOS.ProcSocket_vendor(n:byte):string;
{pro jake procesory je patice urcena - vyrobce}
begin
ProcSocket_vendor:=Device_String_From_Table(4,n,7);
end;

Function T_SMBIOS.ProcSocket_product(n:byte):string;
{pro jake procesory je patice urcena - model}
begin
ProcSocket_product:=Device_String_From_Table(4,n,$10);
end;

Function T_SMBIOS.ProcSocket_socket(n:byte):string;
{Typ procesorove patice}
begin
ProcSocket_socket:=Device_String_From_Table(4,n,4);
end;

Function T_SMBIOS.ProcSocketMaxSpeed(n:byte):word;
{maximalni rychlost procesoru v dane patici}
begin
ProcSocketMaxSpeed:=Device_Word_From_Table(4,n,$14);
end;


Function T_SMBIOS.ProcNum_into_SocketNum(n:byte):byte;
{Vrati v jake patici je procesor N}
var a,b,c:byte;
    w,p:word;
begin
a:=Num_of_specified_tables(4);  {zjisti pocet polozek se znakem "procesor"}
c:=1;
if n<1 then begin ProcNum_into_SocketNum:=0;Exit;end;
for b:=1 to a do
    begin
    w:=Find_specified_table(4,b);
    p:=Data_position(w);
    if (byte(data[p+5])=3) and ((byte(data[p+$18]) and 7)=1) then
       if c=n then begin ProcNum_into_SocketNum:=b;Exit;end else inc(c);
    end;
ProcNum_into_SocketNum:=0;
end;

Function T_SMBIOS.Proc_Is_CPU(n:byte):boolean;
{Je v patici N procesor typu CPU?}
var w,p:word;
begin
w:=Find_specified_table(4,n);
p:=Data_position(w);
Proc_Is_CPU:=(byte(data[p+5])=3) and ((byte(data[p+$18]) and 7)=1);
end;

Function T_SMBIOS.Proc_Num_of_Installed_CPUs:byte;
{Pocet realne instalovanych procesoru typu CPU}
var a,b,c:byte;
    w,p:word;
begin
a:=Num_of_specified_tables(4);  {zjisti pocet polozek se znakem "procesor"}
c:=0;
for b:=1 to a do
    begin
    w:=Find_specified_table(4,b);
    p:=Data_position(w);
    if (byte(data[p+5])=3) and ((byte(data[p+$18]) and 7)=1) then inc(c);
    end;
Proc_Num_of_Installed_CPUs:=c;
end;



Function T_SMBIOS.Proc_vendor(n:byte):string;
{vyrobce procesoru}
var z:byte;
begin
z:=ProcNum_into_SocketNum(n);
if z=0 then Proc_vendor:='' else
   Proc_vendor:=Device_String_From_Table(4,z,7);
end;

Function T_SMBIOS.Proc_product(n:byte):string;
{model procesoru}
var z:byte;
begin
z:=ProcNum_into_SocketNum(n);
if z=0 then Proc_product:='' else
   Proc_product:=Device_String_From_Table(4,z,$10);
end;

Function T_SMBIOS.Proc_socket(n:byte):string;
{v jake je procesor patici?}
var z:byte;
begin
z:=ProcNum_into_SocketNum(n);
if z=0 then Proc_socket:='' else
   Proc_socket:=Device_String_From_Table(4,z,4);
end;

Function T_SMBIOS.ProcSpeed(n:byte):word;
{aktualni rychlost procesoru}
var z:byte;
begin
z:=ProcNum_into_SocketNum(n);
if z=0 then ProcSpeed:=0 else
   ProcSpeed:=Device_Word_From_Table(4,z,$16);
end;

Function T_SMBIOS.Proc_Num_of_All_cores(n:byte):string;
{pocet procesorovych jader}
var z:byte;
    w,j:word;
begin
z:=ProcNum_into_SocketNum(n);
if z=0 then Proc_Num_of_All_cores:='' else
   begin
   w:=Find_specified_table(4,z);
   if Data_Formated_Length(w)<=$23 then Proc_Num_of_All_cores:='1'
      else begin
      j:=Device_Word_From_Table(4,z,$23);
      if j=0 then Proc_Num_of_All_cores:='unknown'
             else Proc_Num_of_All_cores:=MyStr(j);
      end
   end;
end;


Function T_SMBIOS.Proc_Num_of_Enabled_cores(n:byte):string;
{pocet bezicich procesorovych jader}
var z:byte;
    w,j:word;
begin
z:=ProcNum_into_SocketNum(n);
if z=0 then Proc_Num_of_Enabled_cores:='' else
   begin
   w:=Find_specified_table(4,z);
   if Data_Formated_Length(w)<=$24 then Proc_Num_of_Enabled_cores:='1'
      else begin
      j:=Device_Word_From_Table(4,z,$24);
      if j=0 then Proc_Num_of_Enabled_cores:='unknown'
             else Proc_Num_of_Enabled_cores:=MyStr(j);
      end
   end;
end;


Function T_SMBIOS.Memory_Total_Size:longint;
{celkova velikost pameti v megabajtech}
var a,b:byte;
    w,p,v:word;
    mb,kb:longint;
    s:string;
begin
if found=false then begin Memory_Total_Size:=0;Exit;end;
mb:=0; {megabajty}
kb:=0; {kilobajty}
s:=Get_SMBIOS_version;
if (s[1]>'2') or ((s[1]='2') and (s[3]>='1')) then
   begin
   a:=Num_of_specified_tables(17);  {zjisti pocet pametovych slotu}
   for b:=1 to a do
       begin
       v:=Device_Word_From_Table(17,b,$0C);
       if v<>$ffff {neznama hodnota} then
          if v>=$8000 then inc(kb,v and $7fff) else inc(mb,v);
       end;
   Memory_Total_Size:=mb; {opomijim tu kilobajty. Jestli nekdo chce, at si}
   end                    {je pripocte}
   else begin
   a:=Num_of_specified_tables(6);  {zjisti pocet pametovych slotu}
   for b:=1 to a do
       begin
       v:=Device_Byte_From_Table(6,b,$09) and 127;
       if not (v in [$FD,$FE,$FF]) then mb:=mb+Mocn2(v);
       end;
   Memory_Total_Size:=mb;
   end;
end;

Function T_SMBIOS.Mem_Num_of_slots:byte;
{pocet pametovych slotu}
var s:string;
begin
if found=false then begin Mem_Num_of_slots:=0;Exit;end;
s:=Get_SMBIOS_version;
if (s[1]>'2') or ((s[1]='2') and (s[3]>='1'))
   then Mem_Num_of_slots:=Num_of_specified_tables(17)
   else Mem_Num_of_slots:=Num_of_specified_tables(6)
end;


Function T_SMBIOS.Mem_Module_Size_KB(n:byte):longint;
{velkost pametoveho modulu v kilobajtech}
var kb:longint;
    s:string;
    v:word;
begin
Mem_Module_Size_KB:=0;
if found=false then Exit;
kb:=0; {kilobajty}
s:=Get_SMBIOS_version;
if (s[1]>'2') or ((s[1]='2') and (s[3]>='1')) then
   begin
   v:=Device_Word_From_Table(17,n,$0C);
   if v<>$ffff {neznama hodnota} then
      if v>=$8000 then kb:=v and $7fff else kb:=longint(v)*1024;
   end
   else begin
   v:=Device_Byte_From_Table(6,n,$09) and 127;
   if not (v in [$FD,$FE,$FF]) then kb:=longint(Mocn2(v))*1024;
   end;
Mem_Module_Size_KB:=kb;
end;

Function T_SMBIOS.Mem_Module_Size_MB(n:byte):word;
{velkost pametoveho modulu v megabajtech}
begin
Mem_Module_Size_MB:=Mem_Module_Size_KB(n) div 1024;
end;


Function T_SMBIOS.Mem_Speed(n:byte):word;
{aktualni rychlost pametoveho modulu v MHz}
var s:string;
    i:word;
begin
if found=false then begin Mem_Speed:=0;Exit;end;
s:=Get_SMBIOS_version;
if (s[1]>'2') or ((s[1]='2') and (s[3]>='3'))
   then begin
   i:=Device_word_From_Table(17,n,$15);
   Mem_Speed:=i;
   end
   else Mem_Speed:=0;
end;


Function T_SMBIOS.Boot_Status:byte;
var i:byte;
begin
if found=false then begin Boot_status:=255;Exit;end;
i:=Device_byte_from_table(32,1,$0A);
Boot_Status:=i;
end;


Function T_SMBIOS.Mem_Vendor(n:byte):string;
{vyrobce pametoveho modulu}
var s:string;
begin
if found=false then begin Mem_Vendor:='';Exit;end;
s:=Get_SMBIOS_version;
if (s[1]>'2') or ((s[1]='2') and (s[3]>='1'))
   then Mem_Vendor:=Device_string_From_Table(17,n,$17) else Mem_Vendor:='unknown';
end;

Function T_SMBIOS.Mem_Type(n:byte):string;
{typ pametoveho modulu}
   Function MT_table(v:byte):string;
   var s:string;
   begin
   case v of
     1:s:='other';3:s:='DRAM';4:s:='EDRAM';5:s:='VRAM';6:s:='SRAM';
     7:s:='RAM';8:s:='ROM';9:s:='FLASH';$A:s:='EEPROM';$C:s:='EPROM';
     $D:s:='CDRAM';$E:s:='3DRAM';$F:s:='SDRAM';$10:s:='SGRAM';$11:s:='RDRAM';
     $12:s:='DDR';$13:s:='DDR2';$14:s:='DDR2 FB-DIMM';$18:s:='DDR3';$19:s:='FBD2';
   else s:='unknown';
   end;{case}
   MT_table:=s;
   end;
var b:byte;
    t:string;
begin
if found=false then begin Mem_Type:='';Exit;end;
t:=Get_SMBIOS_version;
if (t[1]>'2') or ((t[1]='2') and (t[3]>='1'))
   then begin
   b:=Device_byte_From_Table(17,n,$12);
   Mem_Type:=MT_table(b);
   end else Mem_Type:='unknown';
end;

Function T_SMBIOS.PointDev_Type:string;
{Typ integrovaneho polohovaciho zarizeni}
const PointDevType_string:array[1..9] of string = ('other',
                                                   'unknown',
                                                   'mouse',
                                                   'track ball',
                                                   'track point',
                                                   'glide point',
                                                   'touch pad',
                                                   'touch screen',
                                                   'optical sensor');
var b:byte;
begin
if found=false then begin PointDev_Type:='';Exit;end;
b:=Device_Byte_From_Table(21,1,4);
if b=255 then PointDev_Type:='unknown' else PointDev_Type:=PointDevType_string[b];
end;

Function T_SMBIOS.PointDev_Interface:string;
{Interface integrovaneho polohovaciho zarizeni}
   Function GetPointDevInterface_string(b:byte):string;
   var s:string;
   begin
   s:='';
   case b of
     1:s:='other';
     2:s:='unknown';
     3:s:='serial';
     4:s:='PS/2';
     5:s:='infrared';
     6:s:='HP-HIL';
     7:s:='bus mouse';
     8:s:='ADB (Apple)';
     $A0:s:='bus mouse DB-9';
     $A1:s:='bus mouse u-DIN';
     $A2:s:='USB';
   end;{case}
   GetPointDevInterface_string:=s;
   end;
var b:byte;
begin
if found=false then begin PointDev_Interface:='';Exit;end;
b:=Device_Byte_From_Table(21,1,5);
if b=255 then PointDev_Interface:='unknown' else PointDev_Interface:=GetPointDevInterface_string(b);
end;


Function T_SMBIOS.PointDev_Num_of_Buttons:byte;
{pocet tlacitek integrovaneho polohovaciho zarizeni}
var b:byte;
begin
if found=false then begin PointDev_Num_of_Buttons:=0;Exit;end;
b:=Device_Byte_From_Table(21,1,6);
if b=255 then PointDev_Num_of_Buttons:=0
         else PointDev_Num_of_Buttons:=b;
end;


Function T_SMBIOS.Enclosure_type:string;
{Typ pocitacove skrine}
   Function ET_string(b:byte):string;
   var s:string;
   begin
   case b of
     1:s:='other';
     3:s:='desktop';
     4:s:='low profile desktop';
     5:s:='pizza box';
     6:s:='minitower';
     7:s:='tower';
     8:s:='portable';
     9:s:='laptop';
     $a:s:='notebook';
     $b:s:='handheld';
     $c:s:='docking station';
     $d:s:='all in one';
     $e:s:='subnotebook';
     $f:s:='space saving';
     $10:s:='lunch box';
     else s:='unknown';
   end; {case}
   ET_string:=s;
   end;
var b:byte;
begin
if found=false then begin Enclosure_type:='';Exit;end;
b:=Device_Byte_From_Table(3,1,5);
if b=255 then Enclosure_type:='unknown'
         else Enclosure_type:=ET_string(b and 127);
end;


Function TOROM.Init:boolean;
var w,pci:word;
    o,oo,delka:longint;
    b:boolean;
    mytable:POROM_pole;
begin
amount:=0;
Init:=false;
mytable:=nil;
w:=$b000;

repeat
  o:=0;
  inc(w,$1000);

  repeat
    b:=ProhledejSegment(w,o,65536-2048,2048,#85#170{55AAh});
    if b=true then
       begin
       delka:=MemB(w,o+2);
       if delka=0 then inc(o,2048)
          else begin
          oo:=o;
          if delka mod 4=0 then inc(o,delka*512)
                           else inc(o,(delka div 4+1) * 2048);

          if o<65536 then
             begin
             if mytable=nil then begin New(mytable);Init:=true;end;
             inc(amount);
             mytable^[amount].segm:=w;
             mytable^[amount].offs:=oo;
             mytable^[amount].len:=delka*512;

             pci:=word(MemB(w,oo+$18))+word(MemB(w,oo+$19))*256;

             if RMstring(w,pci,4)='PCIR' then
                begin
                mytable^[amount].is_pci:=true;
                mytable^[amount].vendor_id:=word(MemB(w,pci+4))+word(MemB(w,pci+5))*256;
                mytable^[amount].device_id:=word(MemB(w,pci+6))+word(MemB(w,pci+7))*256;
                mytable^[amount].class:=MemB(w,pci+$D+2);
                mytable^[amount].subclass:=MemB(w,pci+$D+1);
                mytable^[amount].interf:=MemB(w,pci+$D+0);
                end
                else begin
                mytable^[amount].is_pci:=false;
                mytable^[amount].device_id:=0;
                mytable^[amount].vendor_id:=0;
                mytable^[amount].class:=0;
                mytable^[amount].subclass:=0;
                mytable^[amount].interf:=0;
                end;



             end else b:=false;

          end;
       end;

  until b=false;

until w=$E000;

table:=mytable;
end;


Function TOROM.GetSeg(num:byte):word;
begin
GetSeg:=POROM_pole(table)^[num].segm;
end;

Function TOROM.GetOfs(num:byte):word;
begin
GetOfs:=POROM_pole(table)^[num].offs;
end;

Function TOROM.GetLen(num:byte):word;
begin
GetLen:=POROM_pole(table)^[num].len;
end;

Function TOROM.LoadOROM(num:byte):pointer;
{inicializuje pointer a nahraje do nej OROM cislo NUM}
var mytable:POROM_pole;
    p:pointer;
begin
mytable:=table;
GetMem(p,mytable^[num].len);

{$IFDEF FPC}
seg_move(Segment_To_Descriptor(mytable^[num].segm), mytable^[num].offs,
                               get_ds, longint(p),mytable^[num].len);
{$ELSE}
Move(Ptr(mytable^[num].segm,mytable^[num].offs)^,p^,mytable^[num].len);
{$ENDIF}
LoadOROM:=p;
end;

Function TOROM.IsPCI(num:byte):boolean;
begin
IsPCI:=POROM_pole(table)^[num].is_PCI;
end;

Function TOROM.vendor_id(num:byte):word;
begin
vendor_id:=POROM_pole(table)^[num].vendor_id;
end;

Function TOROM.device_id(num:byte):word;
begin
device_id:=POROM_pole(table)^[num].device_id;
end;

Function TOROM.class(num:byte):word;
begin
class:=POROM_pole(table)^[num].class;
end;

Function TOROM.subclass(num:byte):word;
begin
subclass:=POROM_pole(table)^[num].subclass;
end;

Function TOROM.interf(num:byte):word;
begin
Interf:=POROM_pole(table)^[num].interf;
end;


Procedure TOROM.Done;
var mytable:POROM_pole;
begin
mytable:=table;
if mytable<>nil then Dispose(mytable);
table:=nil;
end;


Procedure TPNP_BIOS.Init;
var f:file;
    a:word;
    i:longint;
begin


{Assign(f,'dump.dat');
rewrite(f,1);
Blockwrite(f,Ptr($F000,0)^,$FFFF);
close(f);}


found:=false;
nodesize:=0;
numnodes:=0;
devbuf:=nil;
pnp_segment:=$F000;
pnp_offset:=0;


found:=ProhledejSegment(pnp_segment,pnp_offset,$FFFF,16,'$PnP');
if found=false then
   begin
   pnp_segment:=0;
   pnp_offset:=0;
   FillChar(header_data,36,0);
   end
   else begin            {nalezena znacka $PnP}
   writeln(found);
   writeln(pnp_segment);
   writeln(pnp_offset);
   for a:=0 to sizeof(TPNP_rec)-1 do
       header_data[a]:=MemB(pnp_segment,pnp_offset+a);
   for a:=sizeof(TPNP_rec) to 35 do header_data[0]:=0;

   i:=0;
   for a:=0 to header_data[5]-1 do inc(i,header_data[a]);

   writeln(sizeof(TPNP_rec));
   writeln(header_data[5]);
   writeln(header_data[8]);

   writeln(i);
   writeln(i mod 256);
   writeln((i mod 256)+header_data[8]);

   move(header_data[13],entrypoint,4);

   Internal_Get_Number_and_size_of_device_nodes(nodesize,numnodes);

   GetMem(devbuf,1024);
   FillChar(devbuf^,1024,0);

   end;
end;


{$IFDEF FPC}
Function TPNP_BIOS.InternalCallFunc(func:word;words_2_stack:byte):word;
var r:TrealRegs;
    in_ds,k,res:word;
    in_param:array[0..7] of word;
    i,j,hiw,low:longint;
    p:^dword;

begin
DosMemFillChar(tb_segment,0,tb_size,#0);
for i:=0 to 7 do
    begin
    if fnc_arg[i,1]=0 then in_param[i]:=0 else
    if fnc_arg[i,1]=PNP_arg_type_1 then in_param[i]:=fnc_arg[i,0] and $FFFF else
    if fnc_arg[i,1]=PNP_arg_type_2 then in_param[i]:=tb_segment else
    if fnc_arg[i,1]=PNP_arg_type_3 then
       begin
       in_param[i]:=tb_offset+i*4;
       k:=word(pointer(fnc_arg[i,0])^);
       MemW[tb_segment:tb_offset+i*4]:=k;
       {nakopirovani hodnoty promenne z protektu do TB_bufferu}
       end
       else
    if fnc_arg[i,1]=PNP_arg_type_4 then in_param[i]:=tb_segment else
    if fnc_arg[i,1]=PNP_arg_type_5 then
       begin
       in_param[i]:=tb_offset+42+512*i;
       DosMemPut(tb_segment,tb_offset+42+512*i,devbuf^,nodesize);
       {nakopirovani hodnoty promenne z protektu do TB_bufferu}
       end else in_param[i]:=0;
    end;

in_ds:=PPNP_rec(@header_data)^.rm_16_segm_ds;

Fillchar(r,sizeof(TRealRegs),0);
r.cs:=PPnP_rec(@header_data)^.rm_16_segm;
r.ip:=PPnP_rec(@header_data)^.rm_16_offs;

asm
movzx ecx,words_2_stack  {parametry}
mov edx,ecx
add edx,2              {navic ale Real_DS a CisloFunkce}
xor ebx,ebx
lea esi,in_param
lea edi,r

mov ax,in_ds
push ax                 {Realmodovy DS pro BIOSove rutiny}

@cykl:
mov ax,[esi+ebx]
push ax                 {Postupne ukladani variabilnich parametru}
add ebx,2
loop @cykl

mov cx,func
push cx                 {Jako posledni ulozi cislo funkce}

mov ecx,edx             {Z protektoveho zasobniku na realmodovy ECX wordu}
xor ebx,ebx

mov eax,0301h
int 31h

add esp,edx             {misto serie instrukci POP...}
add esp,edx             {...proste jen zvedneme zasobnik}

mov res,ax
end;


for i:=0 to 7 do
    begin
    if fnc_arg[i,1]=0 then begin end else
    if fnc_arg[i,1]=PNP_arg_type_1 then begin end else
    if fnc_arg[i,1]=PNP_arg_type_2 then begin end else
    if fnc_arg[i,1]=PNP_arg_type_3 then
       begin
       DosMemGet(tb_segment,tb_offset+i*4,j,4);
       p:=pointer(fnc_arg[i,0]);
       p^:=j;
       end
       else
    if fnc_arg[i,1]=PNP_arg_type_4 then begin end else
    if fnc_arg[i,1]=PNP_arg_type_5 then
       begin
       in_param[i]:=tb_offset+42+512*i;

       DosMemGet(tb_segment,tb_offset+42+512*i,devbuf^,nodesize);

       {nakopirovani hodnoty promenne z protektu do TB_bufferu}
       end else in_param[i]:=0;
    end;
InternalCallFunc:=res;
end;
{$ELSE}

Function TPNP_BIOS.InternalCallFunc(func:word;words_2_stack:byte):word;
var in_param:array[0..7] of word;
    i:byte;
    in_ds:word;
    ep:pointer;
    vysl:word;

begin
ep:=entrypoint;
for i:=0 to 7 do in_param[i]:=fnc_arg[i,0] and $FFFF;
in_ds:=PPNP_rec(@header_data)^.rm_16_segm_ds;

asm
push ds
push es
push si
push di

lea di,in_param    {DI = offset pole In_param}
push ss
pop ds             {DS = segment pole In_param}

mov bx,in_ds       {rm_16_segm_ds}

push bx

xor cx,cx
mov cl,words_2_stack

mov bx,0
@cykl:
mov dx,ds:[di+bx]
push dx
add bx,2
loop @cykl

mov bx,func
push bx


call ep

xor bx,bx
mov bl,words_2_stack

add sp,bx
add sp,bx

add sp,4

pop di
pop si
pop es
pop ds
mov vysl,ax
end;
InternalCallFunc:=vysl;
end;
{$ENDIF}


Procedure TPNP_BIOS.Internal_Get_Number_and_size_of_device_nodes(var ns,nd:word);
var nds,nmn:longint;
begin
fnc_arg[0,0]:=seg(nds);fnc_arg[0,1]:=PNP_arg_type_2;
fnc_arg[1,0]:=ofs(nds);fnc_arg[1,1]:=PNP_arg_type_3;
fnc_arg[2,0]:=seg(nmn);fnc_arg[2,1]:=PNP_arg_type_2;
fnc_arg[3,0]:=ofs(nmn);fnc_arg[3,1]:=PNP_arg_type_3;

nds:=0;   {nutne - musim vynulovat nepouzite bajty, co..,}
nmn:=0;   {...se nebudou prepisovat}
InternalCallFunc(0,4);

ns:=nds;
nd:=nmn;
end;


Function TPNP_BIOS.Get_Number_of_device_nodes:word;
begin
Get_Number_of_device_nodes:=numnodes;
end;


Function TPNP_BIOS.Get_Size_of_device_nodes:word;
begin
Get_Size_of_device_nodes:=nodesize;
end;


Function TPNP_BIOS.Get_Device_Info_Buffer(dev:byte):byte;
var ndnum:word;
begin
if nodesize=0 then begin Get_Device_Info_Buffer:=255;Exit;end;
fnc_arg[0,0]:=1;fnc_arg[0,1]:=PNP_arg_type_1;
{stav jaky je prave ted, a ne jaky je planovan na pristi boot}


fnc_arg[1,0]:=seg(devbuf^);fnc_arg[1,1]:=PNP_arg_type_4;
fnc_arg[2,0]:=ofs(devbuf^);fnc_arg[2,1]:=PNP_arg_type_5;

ndnum:=dev;
fnc_arg[3,0]:=seg(ndnum);fnc_arg[3,1]:=PNP_arg_type_2;
fnc_arg[4,0]:=ofs(ndnum);fnc_arg[4,1]:=PNP_arg_type_3;

Get_Device_Info_Buffer:=InternalCallFunc(1,5);
end;


Function TPNP_BIOS.LastDev_size:word;
var w:^word;
begin
if nodesize=0 then LastDev_size:=0 else
   begin
   w:=devbuf;
   LastDev_size:=w^;
   end;
end;


Function TPNP_BIOS.LastDev_handlenumber:byte;
var b:^byte;
begin
if nodesize=0 then LastDev_handlenumber:=0 else
   begin
   b:=devbuf;
   inc(b,2);
   LastDev_handlenumber:=b^;
   end;
end;


Function TPNP_BIOS.LastDev_identifier:string;
var b:^byte;
    h:array[0..3] of byte;
    s:string;
    t:string;
    _l,l:^longint;
begin
if nodesize=0 then LastDev_identifier:='' else
   begin
   b:=devbuf;
   inc(b,3);
   move(b^,h,4);

   s:='1234567';    {inicialne nastavime delku retezce na 7 znaku}
   t:='0123456789ABCDEF';

   s[1]:=char(((h[0] and $7C) shr 2) + $40);
   s[2]:=char(((h[0] and $3) shl 3) + ((h[1] and $E0) shr 5) + $40);
   s[3]:=char((h[1] and $1F) + $40);

   s[4]:=t[h[2] shr 4+1];
   s[5]:=t[h[2] and $0F+1];
   s[6]:=t[h[3] shr 4+1];
   s[7]:=t[h[3] and $0F+1];


   LastDev_identifier:=s;
   end;
end;


Function TPNP_BIOS.LastDev_serialnum:string;
var a,i:byte;
    b:^byte;
    s,t:string;
begin
if nodesize=0 then begin LastDev_serialnum:='';Exit;end;
b:=devbuf;
inc(b,4);
s:='';
for i:=1 to 4 do
    begin
    a:=b^;
    inc(b);
    t:=HexStr(a);
    if length(t)=1 then t:='0'+t;
    s:=t+s;
    end;
LastDev_serialnum:=s;
end;


Function TPNP_BIOS.Get_Configuration_Event(var w:word):byte;
var i:longint;
begin
if nodesize=0 then begin w:=0;Get_Configuration_Event:=255;Exit;end;

i:=0;
fnc_arg[0,0]:=seg(i);fnc_arg[0,1]:=PNP_arg_type_2;
fnc_arg[1,0]:=ofs(i);fnc_arg[1,1]:=PNP_arg_type_3;

Get_Configuration_Event:=InternalCallFunc(3,2); {interne zmeni promennou I}

w:=i;
end;


Function TPNP_BIOS.Get_ISA_Configuration_Structure:byte;
begin
if nodesize=0 then begin Get_ISA_Configuration_Structure:=255;Exit;end;
fnc_arg[0,0]:=seg(devbuf^);fnc_arg[0,1]:=PNP_arg_type_4;
fnc_arg[1,0]:=ofs(devbuf^);fnc_arg[1,1]:=PNP_arg_type_5;
Get_ISA_Configuration_Structure:=InternalCallFunc($40,2);
end;


Function TPNP_BIOS.Get_ISA_Configuration__dataport:word;
var a:^byte;
    b:^word;
begin
if Get_ISA_Configuration_Structure<>0
   then Get_ISA_Configuration__dataport:=0
   else begin
   a:=devbuf;
   inc(a,2);
   b:=pointer(a);
   Get_ISA_Configuration__dataport:=b^;
   end;
end;


Function TPNP_BIOS.Get_ISA_Configuration__CarSelNum:byte;
var a:^byte;
begin
if Get_ISA_Configuration_Structure<>0
   then Get_ISA_Configuration__CarSelNum:=0
   else begin
   a:=devbuf;
   inc(a);
   Get_ISA_Configuration__CarSelNum:=a^;
   end;
end;




Procedure TPNP_BIOS.Done;
begin
found:=false;
pnp_segment:=0;
pnp_offset:=0;
FreeMem(devbuf,1024);
devbuf:=nil;
end;


end.
