498 lines
16 KiB
ObjectPascal
498 lines
16 KiB
ObjectPascal
// Device manager uses WinUSB driver by default!!!
|
|
|
|
unit mr.dev.manager;
|
|
|
|
interface
|
|
uses
|
|
// Vcl.Dialogs,
|
|
System.Classes,
|
|
mr.drv.usb,
|
|
mr.dev.usb;
|
|
// dev.usb.trinity.types;
|
|
|
|
type
|
|
GetDeviceListCallback = reference to function( VendorID : word;
|
|
ProductID : word;
|
|
Description : string;
|
|
Location : string;
|
|
DevicePath : string): boolean;
|
|
|
|
procedure RegisterDriver( DriverClass : TUsbDriverClass);
|
|
//
|
|
procedure RegisterDevice( VendorID : word;
|
|
ProductID : word;
|
|
Capabilities: int64;
|
|
DeviceClass : TUsbDeviceClass);
|
|
//
|
|
function AllocateDevice( DevicePath : string): TUsbDevice;
|
|
// Capabilities: TCapabilities = [];
|
|
// IgnoreCap : boolean = false): TUsbDevice;
|
|
//
|
|
//function AllocateDeviceBySN( SerialNumber: AnsiString;
|
|
// Capabilities: TCapabilities = [];
|
|
// IgnoreCap : boolean = false): TUsbDevice;
|
|
//
|
|
procedure DeallocateDevice( var Device : TUsbDevice);
|
|
//
|
|
procedure GetDeviceList( Callback : GetDeviceListCallback;
|
|
VendorID : word = 0;
|
|
ProductID : word = 0);
|
|
|
|
|
|
implementation
|
|
uses
|
|
system.SysUtils,
|
|
spring.Collections;
|
|
|
|
procedure ParseInstanceId( InstanceId : string;
|
|
var VendorID : word;
|
|
var ProductID : word;
|
|
var Location : string;
|
|
var Description : string); forward;
|
|
|
|
|
|
|
|
// SysUtils,
|
|
// Generics.Collections,
|
|
// drv.usb.winusb,
|
|
// dev.usb.trinity,
|
|
// dev.usb.trinity.utils;
|
|
//
|
|
//type
|
|
//
|
|
//type
|
|
// TUsbDriverMap = TDictionary <AnsiString, TUsbDriverClass>;
|
|
// TUsbDeviceMap = TObjectDictionary<AnsiString, TUsbDeviceInfo>;
|
|
//
|
|
//var
|
|
// UsbDriverAlloc : TUsbDriverMap = nil;
|
|
// UsbDriverMap : TUsbDriverMap = nil;
|
|
// UsbDeviceMap : TUsbDeviceMap = nil;
|
|
//
|
|
//
|
|
|
|
type
|
|
TUsbDeviceSetup = class
|
|
strict protected
|
|
fDriverClass : TUsbDriverClass;
|
|
fDeviceClass : TUsbDeviceClass;
|
|
|
|
fVendorID : word;
|
|
fProductID : word;
|
|
fDescription : string;
|
|
|
|
public
|
|
property DriverClass : TUsbDriverClass read fDriverClass write fDriverClass;
|
|
property DeviceClass : TUsbDeviceClass read fDeviceClass write fDeviceClass;
|
|
property VendorID : word read fVendorID write fVendorID;
|
|
property ProductID : word read fProductID write fProductID;
|
|
property Description : string read fDescription write fDescription;
|
|
end;
|
|
|
|
TUsbDeviceDescriptor = class
|
|
strict protected
|
|
fDeviceSetup : TUsbDeviceSetup;
|
|
fDevicePath : string;
|
|
fLocation : string;
|
|
fAllocated : boolean;
|
|
|
|
strict protected
|
|
function GetDriverClass : TUsbDriverClass;
|
|
function GetDeviceClass : TUsbDeviceClass;
|
|
function GetDescription : string;
|
|
function GetVendorID : word;
|
|
function GetProductID : word;
|
|
|
|
public
|
|
constructor Create( DevicePath: string); reintroduce;
|
|
destructor Destroy; override;
|
|
|
|
public
|
|
property Allocated : boolean read fAllocated write fAllocated;
|
|
property DeviceSetup : TUsbDeviceSetup read fDeviceSetup write fDeviceSetup;
|
|
property DevicePath : string read fDevicePath;
|
|
property Location : string read fLocation;
|
|
|
|
property VendorID : word read GetVendorId;
|
|
property ProductID : word read GetProductID;
|
|
property Description : string read GetDescription;
|
|
end;
|
|
|
|
var
|
|
UsbDeviceSetups : IDictionary< cardinal, TUsbDeviceSetup>;
|
|
UsbDevices : IDictionary< string, TUsbDeviceDescriptor>;
|
|
|
|
// ================================================================================================
|
|
// Register Driver
|
|
// ================================================================================================
|
|
procedure RegisterDriver( DriverClass: TUsbDriverClass);
|
|
var
|
|
vid: word;
|
|
pid: word;
|
|
loc: string;
|
|
dsc: string;
|
|
key: cardinal;
|
|
|
|
uds: TUsbDeviceSetup;
|
|
udd: TUsbDeviceDescriptor;
|
|
|
|
begin
|
|
if UsbDevices = nil then
|
|
UsbDevices := tCollections.CreateDictionary< string, TUsbDeviceDescriptor>([doOwnsValues]);
|
|
|
|
if UsbDeviceSetups = nil then
|
|
UsbDeviceSetups := TCollections.CreateDictionary< cardinal, TUsbDeviceSetup>([doOwnsValues]);
|
|
|
|
DriverClass.Scan( procedure( DevicePath: string)
|
|
begin
|
|
DriverClass.ParseInstanceId( DevicePath, vid, pid, loc, dsc);
|
|
key := (vid shl 16) + pid;
|
|
|
|
// --------------------------------------------------------------
|
|
// add or update (override) an usb device setup entry
|
|
// --------------------------------------------------------------
|
|
if not UsbDeviceSetups.TryGetValue( key, uds) then
|
|
begin
|
|
uds := TUsbDeviceSetup.Create;
|
|
uds.VendorID := vid;
|
|
uds.ProductID := pid;
|
|
|
|
UsbDeviceSetups.Add( key, uds)
|
|
end;
|
|
|
|
uds.DriverClass := DriverClass;
|
|
uds.Description := dsc;
|
|
|
|
// --------------------------------------------------------------
|
|
// add or update (override) an usb device entry
|
|
// --------------------------------------------------------------
|
|
if not UsbDevices.TryGetValue( DevicePath, udd) then
|
|
begin
|
|
udd := TUsbDeviceDescriptor.Create( DevicePath);
|
|
UsbDevices.Add(DevicePath, udd)
|
|
end;
|
|
|
|
udd.DeviceSetup := uds
|
|
end)
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// Register Device
|
|
// ================================================================================================
|
|
procedure RegisterDevice( VendorID : word;
|
|
ProductID : word;
|
|
Capabilities: int64;
|
|
DeviceClass : TUsbDeviceClass);
|
|
var
|
|
key: cardinal;
|
|
uds: TUsbDeviceSetup;
|
|
|
|
begin
|
|
if UsbDeviceSetups = nil then
|
|
UsbDeviceSetups := TCollections.CreateDictionary< cardinal, TUsbDeviceSetup>([doOwnsValues]);
|
|
|
|
key := (VendorID shl 16) + ProductID;
|
|
|
|
if not UsbDeviceSetups.TryGetValue( key, uds) then
|
|
begin
|
|
uds := TUsbDeviceSetup.Create;
|
|
uds.VendorID := VendorID;
|
|
uds.ProductID := ProductID;
|
|
|
|
UsbDeviceSetups.Add( key, uds);
|
|
end;
|
|
|
|
uds.DeviceClass := DeviceClass;
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// Get Device List
|
|
// ================================================================================================
|
|
procedure GetDeviceList( Callback : GetDeviceListCallback;
|
|
VendorID : word = 0;
|
|
ProductID : word = 0);
|
|
begin
|
|
for var udd in UsbDevices.Values do
|
|
if ((VendorID = 0) and (ProductID = 0)) or
|
|
((VendorID = udd.VendorID) and (ProductID = udd.ProductID)) then
|
|
begin
|
|
with udd do
|
|
if not Callback( VendorID, ProductID, Description, Location, DevicePath) then
|
|
break
|
|
end
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// Allocate Device
|
|
// ================================================================================================
|
|
function AllocateDevice( DevicePath: string): TUsbDevice;
|
|
var
|
|
udd: TUsbDeviceDescriptor;
|
|
|
|
begin
|
|
result := nil;
|
|
|
|
assert( UsbDeviceSetups <> nil);
|
|
assert( UsbDevices <> nil);
|
|
|
|
if UsbDevices.TryGetValue( DevicePath, udd) and not udd.Allocated then
|
|
begin
|
|
var ds := udd.DeviceSetup;
|
|
assert( ds <> nil);
|
|
|
|
if (ds.DriverClass <> nil) and (ds.DeviceClass <> nil) then
|
|
begin
|
|
udd.Allocated := true;
|
|
|
|
var drv := ds.DriverClass.Create( DevicePath);
|
|
var dev := ds.DeviceClass.Create( drv);
|
|
|
|
exit(dev)
|
|
end
|
|
end
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// Deallocate Device
|
|
// ================================================================================================
|
|
procedure DeallocateDevice( var Device: TUsbDevice);
|
|
var
|
|
udd: TUsbDeviceDescriptor;
|
|
|
|
begin
|
|
if Assigned(Device) then
|
|
begin
|
|
if UsbDevices.TryGetValue( Device.DevicePath, udd) then
|
|
udd.Allocated := false;
|
|
|
|
// FreeAndNil( Device)
|
|
end
|
|
end;
|
|
|
|
|
|
//// ================================================================================================
|
|
//// allocate device by serial number
|
|
//// ================================================================================================
|
|
//function AllocateDeviceBySN( SerialNumber: AnsiString;
|
|
// Capabilities: TCapabilities = [];
|
|
// IgnoreCap : boolean = false): TUsbDevice;
|
|
//var
|
|
// vid : word;
|
|
// pid : word;
|
|
// loc : string;
|
|
// dsc : string;
|
|
//
|
|
// drv : TUsbDriver;
|
|
// drvc : TUsbDriverClass;
|
|
//
|
|
// dev : TUsbDevice;
|
|
// devc : TUsbDeviceClass;
|
|
//
|
|
// tri : TTrinity;
|
|
// inf : TUsbDeviceInfo;
|
|
// cap : TCapabilities;
|
|
// sn : AnsiString;
|
|
//
|
|
// path : AnsiString;
|
|
//
|
|
//begin
|
|
// result := nil;
|
|
//
|
|
// if Assigned( UsbDriverMap) and Assigned(UsbDeviceMap) then
|
|
// begin
|
|
// for path in UsbDriverMap.Keys do
|
|
// begin
|
|
// ParseInstanceID( path, vid, pid, loc, dsc);
|
|
//
|
|
// drvc := UsbDriverMap.Items[path];
|
|
// devc := nil;
|
|
// cap := [];
|
|
//
|
|
// if (vid = $16d0) and (pid = $0712) then
|
|
// begin
|
|
// try
|
|
// drv := drvc.Create(path);
|
|
// tri := TTrinity.Create(drv);
|
|
//
|
|
// tri.Open;
|
|
// cap := tri.Capabilities;
|
|
// sn := tri.SerialNumber;
|
|
// tri.Close;
|
|
//
|
|
// tri.Free;
|
|
//
|
|
// except
|
|
//
|
|
// end;
|
|
// end;
|
|
//
|
|
// for inf in UsbDeviceMap.Values do
|
|
// if (inf.VendorID = vid) and (inf.ProductID = pid) then
|
|
// if (inf.Capabilities * cap = cap) or IgnoreCap then
|
|
// begin
|
|
// if sn = SerialNumber then
|
|
// begin
|
|
// devc := inf.DeviceClass;
|
|
// break;
|
|
// end;
|
|
// end;
|
|
//
|
|
// if Assigned(devc) then
|
|
// begin
|
|
// drv := drvc.Create(path);
|
|
// dev := devc.Create(drv);
|
|
//
|
|
// if not Assigned( UsbDriverAlloc) then
|
|
// UsbDriverAlloc := TUsbDriverMap.Create;
|
|
//
|
|
// UsbDriverAlloc.Add( path, drvc);
|
|
// UsbDriverMap.Remove(path);
|
|
//
|
|
// result:= dev;
|
|
// end;
|
|
// end
|
|
// end
|
|
//end;
|
|
//
|
|
|
|
|
|
// ================================================================================================
|
|
// parse instnce ID
|
|
// ================================================================================================
|
|
procedure ParseInstanceId( InstanceId : string;
|
|
var VendorID : word;
|
|
var ProductID : word;
|
|
var Location : string;
|
|
var Description : string);
|
|
var
|
|
i : integer;
|
|
l : integer;
|
|
id : string;
|
|
loc: string;
|
|
dsc: string;
|
|
|
|
begin
|
|
i := 1;
|
|
l := Length(InstanceId);
|
|
|
|
while (i<=l) and (InstanceId[i] <> '\') do
|
|
inc(i);
|
|
|
|
inc(i);
|
|
|
|
while (i<=l) and (InstanceId[i] <> '\') do
|
|
begin
|
|
id := id + InstanceId[i];
|
|
inc(i)
|
|
end;
|
|
|
|
inc(i);
|
|
|
|
while (i<=l) and (InstanceId[i] <> '#') do
|
|
begin
|
|
loc := loc + InstanceId[i];
|
|
inc(i)
|
|
end;
|
|
|
|
inc(i);
|
|
|
|
while (i<=l) do
|
|
begin
|
|
dsc := dsc + InstanceId[i];
|
|
inc(i)
|
|
end;
|
|
|
|
if @VendorID <> nil then
|
|
VendorId := StrToInt('$'+Copy( id, 5, 4));
|
|
|
|
ProductId := StrToInt('$'+Copy( id, 14, 4));
|
|
Location := loc;
|
|
Description := dsc
|
|
end;
|
|
|
|
{ TUsbDeviceDescriptor }
|
|
|
|
|
|
|
|
// @@@: UsbDeviceDescriptor +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
//
|
|
// UsbDeviceDescriptor
|
|
//
|
|
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
|
|
// ================================================================================================
|
|
// constructor
|
|
// ================================================================================================
|
|
constructor TUsbDeviceDescriptor.Create(DevicePath: string);
|
|
var
|
|
vid: word;
|
|
pid: word;
|
|
dsc: string;
|
|
|
|
begin
|
|
inherited Create;
|
|
|
|
fAllocated := false;
|
|
fDevicePath := DevicePath;
|
|
|
|
ParseInstanceId( fDevicePath, vid, pid, fLocation, dsc)
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// destructor
|
|
// ================================================================================================
|
|
destructor TUsbDeviceDescriptor.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// get driver class
|
|
// ================================================================================================
|
|
function TUsbDeviceDescriptor.GetDriverClass: TUsbDriverClass;
|
|
begin
|
|
result := fDeviceSetup.DriverClass
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// get device class
|
|
// ================================================================================================
|
|
function TUsbDeviceDescriptor.GetDeviceClass: TUsbDeviceClass;
|
|
begin
|
|
result := fDeviceSetup.DeviceClass
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// get vendor ID
|
|
// ================================================================================================
|
|
function TUsbDeviceDescriptor.GetVendorID: word;
|
|
begin
|
|
result := fDeviceSetup.VendorID
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// get product ID
|
|
// ================================================================================================
|
|
function TUsbDeviceDescriptor.GetProductID: word;
|
|
begin
|
|
result := fDeviceSetup.ProductID
|
|
end;
|
|
|
|
// ================================================================================================
|
|
// get description
|
|
// ================================================================================================
|
|
function TUsbDeviceDescriptor.GetDescription: string;
|
|
begin
|
|
result := fDeviceSetup.Description
|
|
end;
|
|
|
|
initialization
|
|
|
|
finalization
|
|
|
|
end.
|