misc.pas.~1~

Delphi LDAP Authentication Component delphi ldap控件

  {      LDAPAdmin - Misc.pas
  *      Copyright (C) 2003-2006 Tihomir Karlovic
  *
  *      Author: Tihomir Karlovic & Alexander Sokoloff
  *
  *
  * This file 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.
  *
  * This file 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 this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
  }

unit Misc;

interface

uses LdapClasses, Classes, ComCtrls, Windows, Graphics, Forms, Dialogs, Controls;

type
  TStreamProcedure = procedure(Stream: TStream) of object;

  TLVSorterOnSort=procedure(SortColumn:  TListColumn; SortAsc: boolean) of object;

  TListViewSorter=class
  private
    FListView:      TListView;
    FSortColumn:    TListColumn;
    FSortAsc:       boolean;
    FBmp:           TBitmap;
    FOnColumnClick: TLVColumnClickEvent;
    FOnCustomDraw:  TLVCustomDrawEvent;
    FOnSort:        TLVSorterOnSort;
    procedure       SetSortMark; overload;
    procedure       SetSortMark(Column: TListColumn); overload;
    procedure       SetListView(const Value: TListView);
    procedure       DoCustomDraw(Sender: TCustomListView; const ARect: TRect; var DefaultDraw: Boolean);
    procedure       DoColumnClick(Sender: TObject; Column: TListColumn);
    procedure       DoCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
  public
    constructor     Create; reintroduce;
    destructor      Destroy; override;
    property        ListView: TListView read FListView write SetListView;
    property        SortColumn:  TListColumn read FSortColumn;
    property        SortAsc: boolean read FSortAsc;
    property        OnSort: TLVSorterOnSort read FOnSort write FOnSort;
  end;

{ String conversion routines }
function UTF8ToStringLen(const src: PChar; const Len: Cardinal): widestring;
function StringToUTF8Len(const src: PChar; const Len: Cardinal): string;
{ Time conversion routines }
function  DateTimeToUnixTime(const AValue: TDateTime): Int64;
function  UnixTimeToDateTime(const AValue: Int64): TDateTime;
function  GTZToDateTime(AValue: string): TDateTime;
function  LocalDateTimeToUTC(DateTime: TDateTime): TDateTime;
{ String handling routines }
procedure Split(Source: string; Result: TStrings; Separator: Char);
function  FormatMemoInput(const Text: string): string;
function  FormatMemoOutput(const Text: string): string;
{ URL handling routines }
procedure ParseURL(const URL: string; var proto, user, password, host, path: string; var port: integer);
{ Some handy dialogs }
function  CheckedMessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; CbCaption: string; var CbChecked: Boolean): TModalResult;
function  ComboMessageDlg(const Msg: string; const csItems: string; var Text: string): TModalResult;
function MessageDlgEx(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; Captions: array of string; Events: array of TNotifyEvent): TModalResult;
{ everything else :-) }
function  HexMem(P: Pointer; Count: Integer; Ellipsis: Boolean): string;
procedure StreamCopy(pf, pt: TStreamProcedure);
procedure LockControl(c: TWinControl; bLock: Boolean);
function  PeekKey: Integer;
procedure ClassifyLdapEntry(Entry: TLdapEntry; out Container: Boolean; out ImageIndex: Integer);
function  SupportedPropertyObjects(const Index: Integer): Boolean;
procedure RevealWindow(Form: TForm; MoveLeft, MoveTop: Boolean);

const
  mrCustom   = 1000;

implementation

{$I LdapAdmin.inc}

uses SysUtils, CommCtrl, StdCtrls, Messages, Constant {$IFDEF VARIANTS} ,variants {$ENDIF};

{ String conversion routines }

{ Note: these functions ignore conversion errors }
function UTF8ToStringLen(const src: PChar; const Len: Cardinal): widestring;
var
  l: Integer;
begin
  SetLength(Result, Len);
  if Len > 0 then
  begin
    l := MultiByteToWideChar( CP_UTF8, 0, src, Len, PWChar(Result), Len*SizeOf(WideChar));
    SetLength(Result, l);
  end;
end;

function StringToUTF8Len(const src: PChar; const Len: Cardinal): string;
var
  bsiz: Integer;
  Temp: string;
begin
  bsiz := Len * 3;
  SetLength(Temp, bsiz);
  if bsiz > 0 then
  begin
    StringToWideChar(src, PWideChar(Temp), bsiz);
    SetLength(Result, bsiz);
    bsiz := WideCharToMultiByte(CP_UTF8, 0, PWideChar(Temp), -1, PChar(Result), bsiz, nil, nil);
    if bsiz > 0 then dec(bsiz);
    SetLength(Result, bsiz);
  end;
end;

{ Time conversion routines }

function DateTimeToUnixTime(const AValue: TDateTime): Int64;
begin
  Result := Round((AValue - 25569.0) * 86400)
end;

function UnixTimeToDateTime(const AValue: Int64): TDateTime;
begin
  Result := AValue / 86400 + 25569.0;
end;

function GTZToDateTime(AValue: string): TDateTime;
begin
  if (Length(AValue) < 15) or (Uppercase(AValue[Length(AValue)]) <> 'Z') then
        raise EConvertError.Create(stInvalidTimeFmt);
  AValue[15] := ' ';
  Insert(':', AValue, 13);
  Insert(':', AValue, 11);
  Insert(' ', AValue, 9);
  Insert('-', AValue, 7);
  Insert('-', AValue, 5);
  Result := VarToDateTime(AValue);
end;

function LocalDateTimeToUTC(DateTime: TDateTime): TDateTime;
var
  tzi: TTimeZoneInformation;
  err: DWORD;
  Bias: Integer;
begin
  fillchar(tzi, 0, SizeOf(tzi));
  err := GetTimeZoneInformation(tzi);
  if (err = TIME_ZONE_ID_UNKNOWN) or (err = TIME_ZONE_ID_INVALID) then
    //raise Exception.Create(stInvalidTimeZone);
    Result := DateTime
  else begin
    Bias := tzi.Bias;
    if err = TIME_ZONE_ID_DAYLIGHT then
      inc(Bias, tzi.DayLightBias);
    Result := DateTime + Bias * 60 / 86400;
  end;
end;

{ URL handling routines }

procedure  ParseURL(const URL: string; var proto, user, password, host, path: string; var port: integer);
var
  n1, n2: integer;
  AUrl: string;
begin
  //URL format <proto>://<user>:<password>@<host>:<port>/<path>
  AUrl:=Url;
  n1:=pos('://',AURL);
  if n1>0 then begin
    proto:=copy(AURL,1,n1-1);
    Delete(AURL,1,n1+2);
  end;

  n1:=pos('@',AURL);
  if n1>0 then begin
    n2:=pos(':',copy(AURL,1,n1-1));
    if n2>0 then begin
      user:=copy(AURL,1,n2-1);
      password:=copy(AURL,n2+1,n1-n2-1);
    end
    else user:=copy(AURL,1,n1-1);
    Delete(AURL,1,n1);
  end;

  n1:=pos('/',AURL);
  if n1=0 then n1:=length(AURL)+1;
  n2:=pos(':',copy(AURL,1,n1-1));
  if n2>0 then begin
    host:=copy(AURL,1,n2-1);
    port:=StrToIntDef(copy(AURL,n2+1,n1-n2-1),-1);
  end
  else begin
    host:=copy(AURL,1,n1-1);
    if proto='ldaps' then
      port := 636;
  end;

  Delete(AURL,1,n1);

  path:=AURL;
end;


function HexMem(P: Pointer; Count: Integer; Ellipsis: Boolean): string;
var
  i, cnt: Integer;
begin
  Result := '';
  if Count > 64 then
    cnt := 64
  else begin
    cnt := Count;
    Ellipsis := false;
  end;
  for i := 0 to cnt - 1 do
    Result := Result + IntToHex(PByteArray(P)[i], 2) + ' ';
  if Ellipsis and (Result <> '') then
    Result := Result + '...';
end;

{ String handling routines }

procedure Split(Source: string; Result: TStrings; Separator: Char);
var
  p0, p: PChar;
  s: string;
begin
  p0 := PChar(Source);
  p := p0;
  repeat
    while (p^<> #0) and (p^ <> Separator) do
      p := CharNext(p);
    SetString(s, p0, p - p0);
    Result.Add(s);
    if p^ = #0 then
      exit;
    p := CharNext(p);
    p0 := p;
  until false;
end;

{ Address fields take $ sign as newline tag so we have to convert this to LF/CR }

function FormatMemoInput(const Text: string): string;
var
  p: PChar;
begin
  Result := '';
  p := PChar(Text);
  while p^ <> #0 do begin
    if p^ = '$' then
      Result := Result + #$D#$A
    else
      Result := Result + p^;
    p := CharNext(p);
  end;
end;

function FormatMemoOutput(const Text: string): string;
var
  p, p1: PChar;
begin
  Result := '';
  p := PChar(Text);
  while p^ <> #0 do begin
    p1 := CharNext(p);
    if (p^ = #$D) and (p1^ = #$A) then
    begin
      Result := Result + '$';
      p1 := CharNext(p1);
    end
    else
      Result := Result + p^;
    p := p1;
  end;
end;

procedure StreamCopy(pf, pt: TStreamProcedure);
var
  Stream: TMemoryStream;
begin
  Stream := TMemoryStream.Create;
  try
    pf(Stream);
    Stream.Position := 0;
    pt(Stream);
  finally
    Stream.Free;
  end;
end;

procedure LockControl(c: TWinControl; bLock: Boolean);
begin
  if (c = nil) or (c.Parent = nil) or (c.Handle = 0) then Exit;
  if bLock then
    SendMessage(c.Handle, WM_SETREDRAW, 0, 0)
  else
  begin
    SendMessage(c.Handle, WM_SETREDRAW, 1, 0);
    RedrawWindow(c.Handle, nil, 0,
      RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN);
  end;
end;

function PeekKey: Integer;
var
  msg: TMsg;
begin
  PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE);
  if msg.Message = WM_KEYDOWN then
    Result := msg.WParam
  else
    Result := 0;
end;

procedure ClassifyLdapEntry(Entry: TLdapEntry; out Container: Boolean; out ImageIndex: Integer);
var
  Attr: TLdapAttribute;
  j: integer;
  s: string;

  function IsComputer(const s: string): Boolean;
  var
    i: Integer;
  begin
    i := Pos(',', s);
    Result := (i > 1) and (s[i - 1] = '$');
  end;

begin
  Container := true;
  ImageIndex := bmEntry;
  Attr := Entry.AttributesByName['objectclass'];
  j := Attr.ValueCount - 1;
  while j >= 0 do
  begin
    s := lowercase(Attr.Values[j].AsString);
    if s = 'organizationalunit' then
      ImageIndex := bmOu
    else if s = 'posixaccount' then
    begin
      if ImageIndex = bmEntry then // if not yet assigned to Samba account
      begin
        ImageIndex := bmPosixUser;
        Container := false;
      end;
    end
    else if s = 'sambasamaccount' then
    begin
      if IsComputer(Entry.dn) then             // it's samba computer account