If I add Interfaces to the main unit the project compiles fine. But is
it ok to add interfaces to a console application?
I need two LCL unit, LCLtype and LCLintf. I use this unit in order to
get the mac address on windows (using netapi32.dll).
I found a delphi code and I modified it in order to run it on lazarus,
but I didn't understand everything, I only know that actually it works.
Here the code:
{ *********************************************************************** }
{ }
{ Unit containing NetBIOS 3.0 definition }
{ Porting of Nb30 Delphi unit to FreePascal }
{ And GetLoginName Function }
{ }
{ }
{ *********************************************************************** }
unit my_sysinfo;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils
{$IFDEF MSWINDOWS}
, snmp, nb30, dynlibs, LCLtype, LCLintf, LCLProc
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
, baseunix, sockets, users
{$ENDIF};
type
TUser = record
Name: string; { Username. }
Passwd: string; { Password. }
User_id: Cardinal; { User ID. }
Group_id: Cardinal; { Group ID. }
Real_name: string; { Real name. }
Home_dir: string; { Home directory. }
Shell: string; { Shell program. }
end;
function GetMACAddress: string;
function GetUserInfo: TUser;
implementation
{$IFDEF LINUX}
const
IF_NAMESIZE = 16;
SIOCGIFCONF = $8912;
SIOCGIFHWADDR = $8927;
type
{$packrecords c}
tifr_ifrn = record
case integer of
0 : (ifrn_name: array [0..IF_NAMESIZE-1] of char);
end;
tifmap = record
mem_start : cardinal;
mem_end : cardinal;
base_addr : word;
irq : byte;
dma : byte;
port : byte;
end;
PIFrec = ^TIFrec;
TIFrec = record
ifr_ifrn : tifr_ifrn;
case integer of
0 : (ifru_addr : TSockAddr);
1 : (ifru_dstaddr : TSockAddr);
2 : (ifru_broadaddr : TSockAddr);
3 : (ifru_netmask : TSockAddr);
4 : (ifru_hwaddr : TSockAddr);
5 : (ifru_flags : word);
6 : (ifru_ivalue : longint);
7 : (ifru_mtu : longint);
8 : (ifru_map : tifmap);
9 : (ifru_slave : Array[0..IF_NAMESIZE-1] of char);
10 : (ifru_newname : Array[0..IF_NAMESIZE-1] of char);
11 : (ifru_data : pointer);
end;
TIFConf = record
ifc_len : longint;
case integer of
0 : (ifcu_buf : pointer);
1 : (ifcu_req : ^tifrec);
end;
function GetUserInfo: TUser;
var
Data: TPasswordRecord;
begin
GetUserData(FpGetuid, Data);
Result.Name:= Data.pw_name;
Result.Real_name:= Data.pw_gecos;
Result.User_id:= Data.pw_uid;
Result.Group_id:= Data.pw_gid;
Result.home_dir:= Data.pw_dir;
Result.shell:= Data.pw_shell;
end;
(* Taken and modified from macuuid unit in packages/uuid/src/macuuid.pp *)
function GetMACAddress : string;
var
MacAddr: Packed Array[1..6] of byte = (0,0,0,0,0,0);
i,n,Sd : Integer;
buf : Array[0..1023] of byte;
ifc : TIfConf;
ifr : TIFRec;
ifp : PIFRec;
p : PChar;
MACaddress: string;
Found: boolean;
begin
Found:= False;
Result:= '';
sd:=fpSocket(AF_INET,SOCK_DGRAM,IPPROTO_IP);
if (sd<0) then
exit;
Try
ifc.ifc_len:=Sizeof(Buf);
ifc.ifcu_buf:=...@buf;
if fpioctl(sd, SIOCGIFCONF, @ifc)<0 then
Exit;
n:= ifc.ifc_len;
i:=0;
While (Not Found) and (I<N) do
begin
ifp:=PIFRec(PByte(ifc.ifcu_buf)+i);
move(ifp^.ifr_ifrn.ifrn_name,ifr.ifr_ifrn.ifrn_name,IF_NAMESIZE);
StrPLCopy(ifr.ifr_ifrn.ifrn_name, 'eth0', IF_NAMESIZE);
if (fpioctl(sd, SIOCGIFHWADDR, @ifr) >= 0) then
begin
P:=Pchar(@ifr.ifru_hwaddr.sa_data);
Found:=(p[0]<>#0) or (p[1]<>#0) or (p[2]<>#0)
or (p[3]<>#0) or (p[4]<>#0) or (p[5]<>#0);
If Found Then
begin
Move(P^,MacAddr,SizeOf(MacAddr));
end;
end;
I:=I+sizeof(tifrec);
end;
Finally
fileClose(sd);
MACaddress:= '';
For i:=1 to 5 do
MACaddress:= MACaddress + hexstr(MacAddr[i],2) + ':';
Result:= MACaddress + hexstr(MacAddr[6],2);
end;
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
type
TNetBios = function(P: PNCB): Byte; stdcall;
var
NetBiosLib: HINST = 0;
_NetBios: TNetBios;
function AdapterToString(Adapter: PByteArray): string;
begin
Result := Format('%2.2x:%2.2x:%2.2x:%2.2x:%2.2x:%2.2x',
[Adapter^[0], Adapter^[1],
Adapter^[2], Adapter^[3],
Adapter^[4], Adapter^[5]]);
end;
function GetMacAddresses(const Machine: string; const Addresses:
TStringList): Integer;
procedure ExitNetbios;
begin
if NetBiosLib <> 0 then
begin
FreeLibrary(NetBiosLib);
NetBiosLib := 0;
end;
end;
function InitNetbios: Boolean;
begin
Result := True;
if NetBiosLib = 0 then
begin
NetBiosLib := LoadLibrary(PChar('netapi32.dll'));
Result := NetBiosLib <> 0;
if Result then
begin
_NetBios := TNetBios(GetProcAddress(NetBiosLib, PChar('Netbios')));
Result := @_NetBios <> nil;
if not Result then
ExitNetbios;
end;
end;
end;
function NetBios(P: PNCB): Byte;
begin
if InitNetbios then
Result := _NetBios(P)
else
Result := 1; // anything other than NRC_GOODRET will do
end;
procedure GetMacAddressesNetBios;
// Platform SDK
//
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/netbios/netbios_1l82.asp
// Microsoft Knowledge Base Article - 118623
// HOWTO: Get the MAC Address for an Ethernet Adapter
// http://support.microsoft.com/default.aspx?scid=kb;en-us;118623
type
AStat = packed record
adapt: TAdapterStatus;
NameBuff: array [0..29] of TNameBuffer;
end;
var
NCB: TNCB;
Enum: TLanaEnum;
I, L, NameLen: Integer;
Adapter: AStat;
MachineName: string;
begin
MachineName := UpperCase(Machine);
if MachineName = '' then
MachineName := '*';
NameLen := Length(MachineName);
L := NCBNAMSZ - NameLen;
if L > 0 then
begin
SetLength(MachineName, NCBNAMSZ);
FillChar(MachineName[NameLen + 1], L, ' ');
end;
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := Char(NCBENUM);
NCB.ncb_buffer := Pointer(@Enum);
NCB.ncb_length := SizeOf(Enum);
if NetBios(@NCB) = NRC_GOODRET then
begin
Result := Ord(Enum.Length);
for I := 0 to Ord(Enum.Length) - 1 do
begin
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := Char(NCBRESET);
NCB.ncb_lana_num := Enum.lana[I];
if NetBios(@NCB) = NRC_GOODRET then
begin
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := Char(NCBASTAT);
NCB.ncb_lana_num := Enum.lana[I];
Move(MachineName[1], NCB.ncb_callname, SizeOf(NCB.ncb_callname));
NCB.ncb_buffer := PChar(@Adapter);
NCB.ncb_length := SizeOf(Adapter);
if NetBios(@NCB) = NRC_GOODRET then
Addresses.Add(AdapterToString(@Adapter.adapt));
end;
end;
end;
end;
procedure GetMacAddressesSnmp;
const
InetMib1 = 'inetmib1.dll';
DunAdapterAddress: array [0..4] of Byte = ($44, $45, $53, $54, $00);
NullAdapterAddress: array [0..5] of Byte = ($00, $00, $00, $00, $00,
$00);
OID_ipMACEntAddr: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 6);
OID_ifEntryType: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 3);
OID_ifEntryNum: array [0..7] of UINT = (1, 3, 6, 1, 2, 1, 2, 1);
var
PollForTrapEvent: THandle;
SupportedView: PAsnObjectIdentifier;
MIB_ifMACEntAddr: TAsnObjectIdentifier;
MIB_ifEntryType: TAsnObjectIdentifier;
MIB_ifEntryNum: TAsnObjectIdentifier;
VarBindList: TSnmpVarBindList;
VarBind: array [0..1] of TSnmpVarBind;
ErrorStatus, ErrorIndex: TAsnInteger32;
DTmp: Integer;
Ret: Boolean;
MAC: PByteArray;
begin
if LoadSnmp then
try
if LoadSnmpExtension(InetMib1) then
try
MIB_ifMACEntAddr.idLength := Length(OID_ipMACEntAddr);
MIB_ifMACEntAddr.ids := @OID_ipMACEntAddr;
MIB_ifEntryType.idLength := Length(OID_ifEntryType);
MIB_ifEntryType.ids := @OID_ifEntryType;
MIB_ifEntryNum.idLength := Length(OID_ifEntryNum);
MIB_ifEntryNum.ids := @OID_ifEntryNum;
if SnmpExtensionInit(GetTickCount, PollForTrapEvent,
SupportedView) then
begin
VarBindList.list := @VarBind[0];
VarBind[0].name := DEFINE_NULLOID;
VarBind[1].name := DEFINE_NULLOID;
VarBindList.len := 1;
SnmpUtilOidCpy(@VarBind[0].name, @MIB_ifEntryNum);
Ret := SnmpExtensionQuery(SNMP_PDU_GETNEXT, VarBindList,
ErrorStatus, ErrorIndex);
if Ret then
begin
Result := VarBind[0].value.number;
VarBindList.len := 2;
SnmpUtilOidCpy(@VarBind[0].name, @MIB_ifEntryType);
SnmpUtilOidCpy(@VarBind[1].name, @MIB_ifMACEntAddr);
while Ret do
begin
Ret := SnmpExtensionQuery(SNMP_PDU_GETNEXT, VarBindList,
ErrorStatus, ErrorIndex);
if Ret then
begin
Ret := SnmpUtilOidNCmp(@VarBind[0].name,
@MIB_ifEntryType, MIB_ifEntryType.idLength) = SNMP_ERRORSTATUS_NOERROR;
if Ret then
begin
DTmp := VarBind[0].value.number;
if DTmp = 6 then
begin
Ret := SnmpUtilOidNCmp(@VarBind[1].name,
@MIB_ifMACEntAddr, MIB_ifMACEntAddr.idLength) = SNMP_ERRORSTATUS_NOERROR;
if Ret and (VarBind[1].value.address.stream <> nil) then
begin
MAC := PByteArray(VarBind[1].value.address.stream);
if not CompareMem(MAC, @NullAdapterAddress,
SizeOf(NullAdapterAddress)) then
Addresses.Add(AdapterToString(MAC));
end;
end;
end;
end;
end;
end;
SnmpUtilVarBindFree(@VarBind[0]);
SnmpUtilVarBindFree(@VarBind[1]);
end;
finally
UnloadSnmpExtension;
end;
finally
UnloadSnmp;
end;
end;
begin
Result := -1;
Addresses.BeginUpdate;
try
Addresses.Clear;
GetMacAddressesNetBios;
if (Result <= 0) and (Machine = '') then
GetMacAddressesSnmp;
finally
Addresses.EndUpdate;
end;
end;
function GetMACaddress: string;
var
Addresses: TStringList;
begin
Addresses:= TStringList.Create;
if GetMacAddresses('', Addresses) >= 0 then
Result:= Addresses.Strings[0]
else
Result:= '';
end;
{$ENDIF MSWINDOWS}
end.
Andrea Mauri ha scritto:
> I still have to check it, I will try to use only the non visual units.
> I will post how I will solve it.
> andrea
>
> Andrea Mauri ha scritto:
>
>> thanks to all,
>> andrea
>>
>> Mattias Gaertner ha scritto:
>>
>>
>>> On Fri, 24 Apr 2009 19:22:35 +0200
>>> Vincent Snijders <[email protected]> wrote:
>>>
>>>
>>>
>>>
>>>> Andrea Mauri schreef:
>>>>
>>>>
>>>>
>>>>> Dear all,
>>>>> I have a cross-platform console application project.
>>>>> The project were compiled with no problem but actually when I
>>>>> compile it I get the following errors (WinXp lazarus svn fpc 2.2.4).
>>>>> I got this error both with fpc 2.2.2 and fpc 2.2.4, I don't know
>>>>> exactly when this error appears (the svn revision number of
>>>>> lazarus). Suggestions?
>>>>>
>>>>>
>>>>>
>>>> Remove the dependency on the LCL.
>>>>
>>>> Or if it must depend on the LCL, include uses interfaces to the main
>>>> program.
>>>>
>>>>
>>>>
>>> or use only the non visual units. For example lclproc, translations,
>>> etc.
>>>
>>> Mattias
>>> _______________________________________________
>>> Lazarus mailing list
>>> [email protected]
>>> http://www.lazarus.freepascal.org/mailman/listinfo/lazarus
>>>
>>>
>>>
>>>
>>
>>
>
> _______________________________________________
> Lazarus mailing list
> [email protected]
> http://www.lazarus.freepascal.org/mailman/listinfo/lazarus
>
>
_______________________________________________
Lazarus mailing list
[email protected]
http://www.lazarus.freepascal.org/mailman/listinfo/lazarus
