ldapclasses.pas

Delphi LDAP Authentication Component delphi ldap控件

    Attr := Attributes.Add(pszattr);
    Attr.fState := Attr.fState + [asBrowse];
    // get value
    ppBer := ldap_get_values_len(pld, plmEntry, pszAttr);
    if Assigned(ppBer) then
    try
      i := 0;
      while Assigned(PPLdapBervalA(ppBer)[i]) do
      begin
        Attr.AddValue(PPLdapBervalA(ppBer)[i]^.bv_val, PPLdapBervalA(ppBer)[i]^.bv_len);
        Inc(I);
      end;
    finally
      LDAPCheck(ldap_value_free_len(ppBer), false);
    end;
    ber_free(pbe, 0);
    pszAttr := ldap_next_attribute(pld, plmEntry, pbe);
  end;
end;

procedure TLDAPSession.ProcessSearchMessage(const plmSearch: PLDAPMessage; const NoValues: LongBool; Result: TLdapEntryList);
var
  pszdn: PChar;
  plmEntry: PLDAPMessage;
  Entry: TLdapEntry;
begin
  try
    // loop thru entries
    plmEntry := ldap_first_entry(pld, plmSearch);
    while Assigned(plmEntry) do
    begin
      pszdn := ldap_get_dn(pld, plmEntry);
      Entry := TLdapEntry.Create(Self, pszdn);
      Result.Add(Entry);
      if not NoValues then
      begin
        Entry.fState := [esReading];
        try
          ProcessSearchEntry(plmEntry, Entry.Attributes);
          Entry.fState := Entry.fState + [esBrowse]; 
        finally
          Entry.fState := Entry.fState - [esReading];
        end;
      end;
      if Assigned(pszdn) then
        ldap_memfree(pszdn);
      plmEntry := ldap_next_entry(pld, plmEntry);
    end;
  finally
    // free search results
    LDAPCheck(ldap_msgfree(plmSearch), false);
  end;
end;

procedure TLDAPSession.Search(const Filter, Base: string; const Scope: Cardinal; attrs: PCharArray; const NoValues: LongBool; Result: TLdapEntryList; SearchProc: TSearchCallback = nil);
var
  plmSearch: PLDAPMessage;
  Err: Integer;
  ServerControls: PLDAPControlA;
  ClientControls: PLDAPControlA;
  SortKeys: PLDAPSortKeyA;
  HSrch: PLDAPSearch;
  TotalCount: Cardinal;
  Timeout: LDAP_TIMEVAL;
  AbortSearch: Boolean;
begin

  if not fPagedSearch then
  begin
    Err := ldap_search_s(pld, PChar(Base), Scope, PChar(Filter), PChar(attrs), Ord(NoValues), plmSearch);
    if Err = LDAP_SIZELIMIT_EXCEEDED then
      MessageDlg(ldap_err2string(err), mtWarning, [mbOk], 0)
    else
      LdapCheck(Err);
    ProcessSearchMessage(plmSearch, NoValues, Result);
    Exit;
  end;

  ServerControls:=nil;
  ClientControls:=nil;
  SortKeys:=nil;
  hsrch:=ldap_search_init_page(pld, PChar(Base), Scope, PChar(Filter), PPCharA(attrs), Ord(NoValues),
                                   ServerControls, ClientControls, 60, 0, SortKeys);
  if not Assigned(hsrch) then
  begin
    Err := LdapGetLastError;
    if Err <> LDAP_NOT_SUPPORTED then
      LdapCheck(Err); // raises exception
    fPagedSearch := false;
    LdapCheck(ldap_search_s(pld, PChar(Base), Scope, PChar(Filter), PChar(attrs), Ord(NoValues), plmSearch)); // try ordinary search
    ProcessSearchMessage(plmSearch, NoValues, Result);
    Exit;
  end;

  Timeout.tv_sec := 60;
  while true do
  begin
    Err := ldap_get_next_page_s(pld, hsrch, Timeout, fPageSize, TotalCount, plmSearch);
    case Err of
      LDAP_UNAVAILABLE_CRIT_EXTENSION, LDAP_UNWILLING_TO_PERFORM:
          begin
            fPagedSearch := false;
            ldap_search_abandon_page(pld, hsrch);
            LdapCheck(ldap_search_s(pld, PChar(Base), Scope, PChar(Filter), PChar(attrs), Ord(NoValues), plmSearch)); // try ordinary search
            ProcessSearchMessage(plmSearch, NoValues, Result);
            Break;
          end;
    LDAP_NO_RESULTS_RETURNED, LDAP_SIZELIMIT_EXCEEDED:
        begin
          if Err = LDAP_SIZELIMIT_EXCEEDED then
          begin
            ProcessSearchMessage(plmSearch, NoValues, Result);
            MessageDlg(ldap_err2string(err), mtWarning, [mbOk], 0)
          end;
          LdapCheck(ldap_search_abandon_page(pld, hsrch));
          break;
        end;
    LDAP_SUCCESS:
        begin
          if not Assigned(plmSearch) then
            Continue;
          ProcessSearchMessage(plmSearch, NoValues, Result);
          if Assigned(SearchProc) then
          begin
            AbortSearch := false;
            SearchProc(Result, AbortSearch);
            if AbortSearch then
            begin
              LdapCheck(ldap_search_abandon_page(pld, hsrch));
              break;
            end;
          end;
        end
    else
      LdapCheck(Err);
    end;
  end;
end;


procedure TLdapSession.Search(const Filter, Base: string; const Scope: Cardinal; QueryAttrs: array of string; const NoValues: LongBool; Result: TLdapEntryList; SearchProc: TSearchCallback = nil);
var
  attrs: PCharArray;
  len: Integer;
begin
  attrs := nil;
  len := Length(QueryAttrs);
  if Len > 0 then
  begin
    SetLength(attrs, len + 1);
    attrs[len] := nil;
    repeat
      dec(len);
      attrs[len] := PChar(QueryAttrs[len]);
    until len = 0;
  end;
  Search(Filter, Base, Scope, attrs, NoValues, Result, SearchProc);
end;

{ Modify set of attributes in every entry set returned by search filter }
procedure TLdapSession.ModifySet(const Filter, Base: string;
                                 const Scope: Cardinal;
                                 argNames: array of string;
                                 argVals: array of string;
                                 argNewVals: array of string;
                                 const ModOp: Cardinal);
var
  List: TLdapEntryList;
  attrs: PCharArray;
  Entry: TLDapEntry;
  h, i: Integer;
begin
  List := TLdapEntryList.Create;
  try
    h := High(argNames);
    SetLength(attrs, h + 2);
    for i := 0 to High(argNames) do
      attrs[i] := PChar(argNames[i]);
    attrs[h + 1] := nil;
    Search(Filter, Base, Scope, attrs, false, List);
    for i := 0 to List.Count - 1 do
    begin
      Entry := TLdapEntry(List[i]);
      for h := 0 to High(argNames) do with Entry.AttributesByName[argNames[h]] do
      begin
        case ModOp of
          LdapOpDelete:  DeleteValue(argVals[h]);
          LdapOpAdd:     AddValue(argNewVals[h]);
          LdapOpReplace: if IndexOf(argVals[h]) <> -1 then
                         begin
                           DeleteValue(argVals[h]);
                           AddValue(argNewVals[h]);
                         end;
          end;
        Entry.Write;
      end;
    end;
  finally
    List.Free;
  end;
end;

procedure TLDAPSession.WriteEntry(Entry: TLdapEntry);
var
  i, j, acnt, addidx, delidx, repidx: Integer;
  attrs: PPLDapMod;
  AttributeList: TLdapAttributeList;

  procedure ValueModOp(AValue: TLdapAttributeData; var idx: Integer);
  var
    pix: Integer;
  begin
    if idx < 0 then  // new entry
    begin
      if acnt = High(attrs) then            // we need trailing NULL
        SetLength(attrs, acnt + 10);        // expand array if neccessary
      idx := acnt;
      GetMem(attrs[acnt], SizeOf(LDAPMod));
      with attrs[acnt]^ do
      begin
        mod_op := AValue.ModOp or LDAP_MOD_BVALUES;
        mod_type := PChar(AValue.fAttribute.Name);
        modv_bvals := nil;        // MUST be nil before call to SetLength!
        SetLength(PPLdapBervalA(modv_bvals), 2);
        PPLdapBervalA(modv_bvals)[0] := AValue.BerVal;
        PPLdapBervalA(modv_bvals)[1] := nil;   // trailing NULL
      end;
      Inc(acnt);
    end
    else begin
      with attrs[idx]^ do begin
        pix := Length(PPLdapBervalA(modv_bvals));
        PPLdapBervalA(modv_bvals)[pix - 1] := AValue.BerVal;
        Setlength(PPLdapBervalA(modv_bvals), pix + 1);
        PPLdapBervalA(modv_bvals)[pix] := nil;  // trailing NULL
      end;
    end;
  end;

  procedure DeleteAll(const AttributeName: string);
  begin
    if acnt = High(attrs) then            // we need trailing NULL
      SetLength(attrs, acnt + 10);        // expand array if neccessary
    GetMem(attrs[acnt], SizeOf(LDAPMod));
    with attrs[acnt]^ do
    begin
      mod_op := LDAP_MOD_DELETE;
      mod_type := PChar(AttributeName);
      modv_bvals := nil;
    end;
    Inc(acnt);
  end;

begin
  AttributeList := Entry.Attributes; // for faster access
  SetLength(attrs, 10); // TODO ModopCount, acnt -> ModopCount
  acnt := 0;
  try
    for i := 0 to AttributeList.Count - 1 do
    begin
      if asDeleted in AttributeList[i].State then
        DeleteAll(AttributeList[i].Name)
      else
      if asModified in AttributeList[i].State then
      begin
        addidx := -1;
        delidx := -1;
        repidx := -1;
        for j := 0 to AttributeList[i].ValueCount - 1 do
          case AttributeList[i][j].ModOp of
            LDAP_MOD_ADD:     ValueModop(AttributeList[i][j], addidx);
            LDAP_MOD_DELETE:  ValueModop(AttributeList[i][j], delidx);
            LDAP_MOD_REPLACE: ValueModop(AttributeList[i][j], repidx);
          end;
      end;
    end;
    attrs[acnt] := nil;  // trailing NULL
    if acnt > 0 then
    begin
      if esNew in Entry.State then
        LdapCheck(ldap_add_s(pld, PChar(Entry.dn), PLDAPMod(attrs)))
      else
        LdapCheck(ldap_modify_s(pld, PChar(Entry.dn), PLDAPMod(attrs)));
    end;
  finally
    for i := 0 to acnt - 1 do
      FreeMem(attrs[i]);
  end;
end;

procedure TLDAPSession.ReadEntry(Entry: TLdapEntry);
var
  plmEntry: PLDAPMessage;

  procedure DoRead(attrs: PCharArray; AttributeList: TLdapAttributeList);
  begin
    LdapCheck(ldap_search_s(pld, PChar(Entry.dn), LDAP_SCOPE_BASE, sANYCLASS, PChar(attrs), 0, plmEntry));
    try
      if Assigned(plmEntry) then
         ProcessSearchEntry(plmEntry, AttributeList);
    finally
      // free search results
      LDAPCheck(ldap_msgfree(plmEntry), false);
    end;
  end;

begin
  DoRead(nil, Entry.Attributes);
  if Assigned(fOperationalAttrs) then
    DoRead(fOperationalAttrs, Entry.OperationalAttributes);
end;

procedure TLdapSession.DeleteEntry(const adn: string);
begin
  LdapCheck(ldap_delete_s(pld, PChar(adn)));
end;

{ Get random free uidNumber from the pool of available numbers, return -1 if
  no more free numbers available }
function TLDAPSession.GetFreeNumber(const Min, Max: Integer; const Objectclass, id: string): Integer;
var
  i: Integer;
  uidpool: array of Word;
  r, N: Word;
begin
  N := Max - Min + 1;
  SetLength(uidpool, N);
  { Initialize the array }
  for i := 0 to N - 1 do
    uidpool[i] := i;
  Randomize;
  while N > 0 do
  begin
    r := Random(N);
    Result := Min + uidpool[r];
    if Lookup(Base, Format('(&(objectclass=%s)(%s=%d))', [Objectclass, id, Result]), 'objectclass', LDAP_SCOPE_SUBTREE) = '' then
      exit;
    uidpool[r] := uidpool[N - 1];
    dec(N);
  end;
  Result := -1;
end;

function TLDAPSession.GetFreeUidNumber(const MinUid, MaxUID: Integer): Integer;
begin
  Result := GetFreeNumber(MinUid, MaxUid, 'posixAccount', 'uidNumber');
  if Result = -1 then
    raise Exception.Create(Format(stNoMoreNums, ['uidNumber']));
end;

function TLDAPSession.GetFreeGidNumber(const MinGid, MaxGid: Integer): Integer;
begin
  Result := GetFreeNumber(MinGid, MaxGid, 'posixGroup', 'gidNumber');
  if Result = -1 then
    raise Exception.Create(Format(stNoMoreNums, ['gidNumber']));
end;

function TLDAPSession.Lookup(sBase, sFilter, sResult: string; Scope: ULONG): string;
var
  plmSearch, plmEntry: PLDAPMessage;
  attrs: PCharArray;
  ppcVals: PPCHAR;
begin
    // set result to sResult only
    SetLength(attrs, 2);
    attrs[0] := PChar(sResult);
    attrs[1] := nil;
    Result := '';
    // perform search
    LdapCheck(ldap_search_s(pld, PChar(sBase), Scope, PChar(sFilter), PChar(attrs), 0, plmSearch));
    try
      plmEntry := ldap_first_entry(pld, plmSearch);
      if Assigned(plmEntry) then
      begin
        ppcVals := ldap_get_values(pld, plmEntry, attrs[0]);
        try
          if Assigned(ppcVals) then
            Result := pchararray(ppcVals)[0];
        finally
          LDAPCheck(ldap_value_free(ppcVals), false);
        end;
      end;
    finally
      // free search results
      LDAPCheck(ldap_msgfree(plmSearch), false);
    end;
end;

function TLDAPSession.GetDn(sFilter: string): string;
var
  plmSearch, plmEntry: PLDAPMessage;
  attrs: PCharArray;
begin
    // set result to dn only
    SetLength(attrs, 2);
    attrs[0] := 'objectclass';
    attrs[1] := nil;
    Result := '';
    // perform search
    LdapCheck(ldap_search_s(pld, PChar(ldapBase), LDAP_SCOPE_SUBTREE, PChar(sFilter), PChar(attrs), 1, plmSearch));
    try
      plmEntry := ldap_first_entry(pld, plmSearch);
      if Assigned(plmEntry) then
        Result := ldap_get_dn(pld, plmEntry);
    finally
      // free search results
      LDAPCheck(ldap_msgfree(plmSearch), false);
    end;
end;

procedure TLDAPSession.SetServer(Server: string);
begin
  Disconnect;
  ldapServer := Server;
end;

procedure TLDAPSession.SetUser(User: string);
begin
  Disconnect;
  ldapUser := User;
end;

procedure TLDAPSession.SetPassword(Password: string);
begin
  Disconnect;
  ldapPassword := Password;
end;

procedure TLDAPSession.SetPort(Port: Integer);
begin
  Disconnect;
  ldapPort := Port;
end;

procedure TLDAPSession.SetVersion(Version: Integer);
begin
  Disconnect;
  ldapVersion := Version;
end;