Ye old network snippets revisited

Networking

Lately I have been looking at some code for ordinary, average networking tasks. Simple stuff like “how do you get the workgroup name” or “how do you get the computer name”. Functions that should be fairly commonplace in our day and age. But there is a world of pain on the internet when it comes to snippets like this. Everyone makes mistakes so I’m not pointing any fingers, but a quick visit to MSDN unveils a horror of memory leaks, incompatible datatypes and code that will make your citrix administrator permanently ban you.

Here are some routines I updated (most of them collected here and there). Tested on Windows 8 and Windows 7 under Citrix.

  class function TNetUtils.getUserName:String;
  var
    BufferSize: DWORD;
    pUser: PChar;
  begin
    // Extract default system-buffer size
    BufferSize := 0;
    winapi.Windows.GetUserName(nil, BufferSize);

    // Allocate string to match system buffer
    pUser := StrAlloc(BufferSize);
    try
      if winapi.Windows.GetUserName(pUser, BufferSize) then
      result := pUser;
    finally
      StrDispose(pUser);
    end;
  end;

  class function TNetUtils.getDomainController:String;
  var
    BufPtr:   PChar;
  begin
    BufPtr:=NIL;
    (* API reference material:
      msdn.microsoft.com/en-us/library/windows/desktop/aa370420(v=vs.85).aspx *)
    if netGetDCName(nil,nil,BufPtr)=NERR_SUCCESS then
    Begin
      try
        Result := BufPtr;
      finally
        NetApiBufferFree(BufPtr);
      end;
    end;
  end;

  class function TNetUtils.getDomainController(Const aDomain:String):String;
  var
    BufPtr: PChar;
  begin
    if length(aDomain)>0 then
    Begin
    (* API reference material:
      msdn.microsoft.com/en-us/library/windows/desktop/aa370420(v=vs.85).aspx *)
      if NetGetDCName(nil,PChar(aDomain),BufPtr)=NERR_SUCCESS then
      Begin
        try
          Result := BufPtr;
        finally
          NetApiBufferFree(BufPtr);
        end;
      end;
    end else
    result:=getDomainController;
  end;

  class function TNetUtils.getComputerName:String;
  var
    mSize: DWord;
    mBuffer: PChar;
  begin
    (* API reference material:
    msdn.microsoft.com/en-us/library/windows/desktop/ms724295(v=vs.85).aspx *)
    mSize:=(MAX_COMPUTERNAME_LENGTH + 1) * SizeOf(WideChar);

    (* Allocate buffer *)
    mBuffer:=allocmem(mSize);
    try
      (* Get the computer name *)
      if winapi.Windows.GetComputerName(mBuffer, mSize) then
      result:=mBuffer;
    finally
      freeMem(mBuffer);
    end;
  end;

  class function TNetUtils.getWorkGroupName:String;
  var
    Info: P_WKSTA_INFO_100;
  begin
    setLength(result,0);
    (* API reference material:
    msdn.microsoft.com/en-us/library/windows/desktop/aa370663(v=vs.85).aspx *)
    if NetWkstaGetInfo(NIL,100,info)=NERR_SUCCESS then
    Begin
      try
        result:=info.wki100_langroup;
      finally
        NetApiBufferFree(info);
      end;
    end;
  end;

  class function TNetUtils.getUserDomain:string;
  begin
    result:=getUserDomain(getUserName);
  end;

  class function TNetUtils.getUserDomain(aUserName:String):String;
  const
    DNLEN = 255;
  var
    sid               : PSID;
    sidSize           : DWORD;
    sidNameUse        : DWORD;
    domainNameSize    : DWORD;
    domainName        : array[0..DNLEN] of char;
    vlSize : ^DWORD;
  begin
    aUsername:=Trim(aUserName);
    if length(aUserName)<1 then
    raise Exception.Create
    ('Unable to extract domain, username was empty');

    domainNameSize := DNLEN + 1;
    sidNameUse := SidTypeUser;

    (* try the "proper" way *)
    sidSize := 65536;
    sid:=AllocMem(sidSize);
    try
      if LookupAccountName(nil, PChar(aUserName), sid, sidSize,
      domainName, domainNameSize, sidNameUse) then
      Result:=StrPas(domainName);
    finally
      FreeMem(sid);
    end;

    (* Fallback mechanism, check environment variables *)
    if length(result)<1 then
    Begin
      New(vlSize);
      try
        vlSize^ := 1024;
        ExpandEnvironmentStrings(PChar('%USERDOMAIN%'), domainName, vlSize^);
        Result := domainName;
      finally
        Dispose(vlSize);
      end;
    end;
  end;

And some updated declarations which doesnt mix ansi and widestring into a nest of pigs:

  type

  P_WKSTA_INFO_100 = ^T_WKSTA_INFO_100;
  _WKSTA_INFO_100 = record
    wki100_platform_id: DWORD;
    wki100_computername: PChar;
    wki100_langroup: PChar;
    wki100_ver_major: DWORD;
    wki100_ver_minor: DWORD;
  end;
  T_WKSTA_INFO_100 = _WKSTA_INFO_100;

  function  NetApiBufferAllocate
            (ByteCount: DWORD;
            var Buffer:Pointer):DWORD;
            stdcall; external 'netapi32.dll';

  function  NetApiBufferFree
            (Buffer: Pointer): DWORD;
            stdcall;external 'netapi32.dll';

  function  NetGetDCName
            (servername:PChar;
            domainname:PChar;
            var bufptr):DWORD;
            stdcall; external 'netapi32.dll';

  Function  NetWkstaGetInfo
            (ServerName : PChar;
            Level      : DWORD;
            var BufPtr) : DWord;
            Stdcall; external 'netapi32.dll';

Virtual canvas

Jam jam jam

Ever wanted to simplify polygon creation? Perhaps add functions like line, circle and rectangle?
Well I decided to slap together a simple bare-bones virtual canvas that basically draws into an array of TPoints.
Just for fun i also included functions to rotate the resulting point buffer (which is cool but not that useful).

Also, I added two modes of drawing: the first plots everything, the second stores each drawing operation as a list of instructions.
The plan is that if you want to draw the result to a TCanvas, then we can use the native TCanvas methods to render it more correctly.

Have fun!

 

  unit vcanvas;

  interface

  uses  System.SysUtils, System.Classes, Vcl.Graphics, System.Math,
        System.Types,System.Generics.Collections;

  const
  CNT_VCAN_PLOT = 1;
  CNT_VCAN_LINE = 2;
  CNT_VCAN_POLY = 3;
  CNT_VCAN_RECT = 4;

  type

  TVirtualCanvasOpCode = Record
    coCode:   Integer;
    coV1:     Real;
    coV2:     Real;
    coData:   Array of TPoint;
    Constructor Create(const aInstr:Integer;
                const aValues:Array of TPoint);overload;

    constructor Create(const aInstr:Integer;
                const v1:real;
                const aValues:Array of TPoint);overload;

    Constructor Create(const aInstr:Integer;
                const V1,V2:Real;
                const aValues:Array of TPoint);overload;
  End;

  TVirtualCanvas = Class(TObject)
  private
    FStack:     TList<TPoint>;
    FInstr:     TList<TVirtualCanvasOpCode>;
    FOverlap:   Boolean;
    FOps:       Boolean;
  protected
    procedure   AddItem(const aLeft,aTop:Integer);overload;
    procedure   AddItem(const aItem:TPoint);overload;
  public
    Property    UseOps:Boolean read FOps write FOps default false;
    Property    Overlapping:boolean read FOverlap write FOverlap default true;
    Property    Items:TList<TPoint> read FStack;
    Procedure   Plot(const aLeft,aTop:Integer);overload;
    Procedure   Plot(const aPoint:TPoint);overload;
    Procedure   Line(const x1,y1,x2,y2:Integer);overload;
    procedure   Line(const aStart,aStop:TPoint);overload;
    Procedure   Rectangle(const cx,cy,wd,hd:Integer;const aAngle:Integer=0);
    Procedure   DrawTo(Const aCanvas:TCanvas);
    Procedure   Polygon(const aPoints:Array of TPoint);

    Procedure   Circle(cx,cy,radius:Integer);

    function    Bounds:TRect;
    function    FindCenter:TPoint;

    Procedure   Rotate(angle:integer);
    Procedure   Scale(factor:Real);

    Constructor Create;virtual;
    Destructor  Destroy;Override;
  End;

  implementation

  //##########################################################################
  //  TVirtualCanvasOpCode
  //##########################################################################

  Constructor TVirtualCanvasOpCode.Create(const aInstr:Integer;
              const aValues:Array of TPoint);
  var
    x:  Integer;
    mLen: Integer;
  Begin
    coCode:=aInstr;
    coV1:=0.0;
    coV2:=0.0;
    mLen:=length(aValues);
    setLength(coData,mLen);
    for x:=0 to mLen-1 do
    coData[x]:=aValues[x];
  end;

  constructor TVirtualCanvasOpCode.Create(const aInstr:Integer;
              const v1:real;
              const aValues:Array of TPoint);
  var
    x:  Integer;
    mLen: Integer;
  Begin
    coCode:=aInstr;
    coV1:=v1;
    coV2:=0.0;
    mLen:=length(aValues);
    setLength(coData,mLen);
    for x:=0 to mLen-1 do
    coData[x]:=aValues[x];
  end;

  Constructor TVirtualCanvasOpCode.Create(const aInstr:Integer;
              const V1,V2:Real;
              const aValues:Array of TPoint);
  var
    x:  Integer;
    mLen: Integer;
  Begin
    coCode:=aInstr;
    coV1:=V1;
    coV2:=V2;
    mLen:=length(aValues);
    setLength(coData,mLen);
    for x:=0 to mLen-1 do
    coData[x]:=aValues[x];
  end;

  //##########################################################################
  //  TVirtualCanvas
  //##########################################################################

  Constructor TVirtualCanvas.Create;
  Begin
    inherited;
    FStack:=TList<TPoint>.Create;
    FInstr:=TList<TVirtualCanvasOpCode>.Create;
  end;

  Destructor  TVirtualCanvas.Destroy;
  Begin
    FStack.free;
    FInstr.Free;
    inherited;
  end;

  function TVirtualCanvas.Bounds:TRect;
  var
    pt : TPoint;
  begin
    if FStack.Count>0 then
    Begin
      pt:=FStack[0];
      Result.Left := pt.X;
      Result.Top := pt.Y;
      Result.Right := pt.X;
      Result.Bottom := pt.Y;
      for pt in FStack do
      Begin
        if pt.X<Result.Left then
        Result.Left := pt.X else
        if pt.X>Result.Right then
        Result.Right := pt.X;

        if pt.Y<Result.Top then
        Result.Top := pt.Y else
        if pt.Y>Result.Bottom then
        Result.Bottom := pt.Y;
      end;
    end;
  end;

  function TVirtualCanvas.FindCenter:TPoint;
  var
    mBounds:  TRect;
  Begin
    if FStack.Count>0 then
    result:=Bounds.CenterPoint else
    result:=TPoint.Create(-1,-1);
  end;

  procedure TVirtualCanvas.Scale(factor:Real);
  var
     i : Integer;
     dx, dy : Real;
     mItem: TPoint;
     mCenter: TPoint;
  begin
    mCenter:=FindCenter;
    dx := mCenter.X * (1.0-factor);
    dy := mCenter.Y * (1.0-factor);
    for i := 0to FStack.Count-1 do
    begin
      FStack.Items[i]:=TPoint.Create(Round( FStack[i].X * factor + dx ),
      Round( FStack[i].Y * factor + dy ));
    end;
  end;

  Procedure TVirtualCanvas.Rotate(angle: integer);
  var
   i : Integer;
   c, s, dx, dy : Real;
   mCenter: TPoint;
  begin
    if FStack.Count>0 then
    Begin
      angle:=EnsureRange(angle,0,360);
      mCenter:=FindCenter;
      c := cos(angle * PI / 180);
      s := sin(angle * PI / 180);
      for i := 0 to FStack.Count-1 do
      begin
        dx := FStack[i].X - mCenter.X;
        dy := FStack[i].Y - mCenter.Y;
        FStack.Items[i]:=TPoint.Create(Round(mCenter.X + dx*c - dy*s),
        Round(mCenter.Y + dx*s + dy*c));
      end;
    end;
  end;

  Procedure TVirtualCanvas.DrawTo(Const aCanvas:TCanvas);
  var
    x:      Integer;
    mInstr: TVirtualCanvasOpCode;
  Begin
    if assigned(aCanvas) then
    Begin
      if not FOps then
      Begin
        for x:=0 to FStack.Count-1 do
        aCanvas.Pixels[FStack[x].X,FStack[x].Y]:=aCanvas.Pen.Color;
      end else
      Begin
        for x:=0 to FInstr.Count-1 do
        Begin
          mInstr:=FInstr[x];
          case mInstr.coCode of
          CNT_VCAN_PLOT:
            Begin
              aCanvas.Pixels[mInstr.coData[0].X,mInstr.coData[0].Y]:=aCanvas.Pen.Color;
            end;
          CNT_VCAN_LINE:
            Begin
              aCanvas.MoveTo(mInstr.coData[0].X,mInstr.coData[0].Y);
              aCanvas.LineTo(mInstr.coData[1].X,mInstr.coData[1].Y);
            end;
          CNT_VCAN_POLY:
            Begin
              aCanvas.Polygon(mInstr.coData);
            end;
          CNT_VCAN_RECT:
            Begin
              //VCL has no rotated rectangle
              aCanvas.Polygon(mInstr.coData);
            end;
          end;
        end;
      end;
    end;
  end;

  procedure TVirtualCanvas.AddItem(const aLeft,aTop:Integer);
  var
    mPoint: TPoint;
    mIndex: Integer;
  Begin
    if not FOverlap then
    Begin
      (* Only add point if not already in stack *)
      mPoint:=TPoint.Create(aLeft,aTop);
      mIndex:=FStack.IndexOf(mPoint);
      if mIndex<0 then
      FStack.Add(TPoint.Create(aleft,atop));
    end else
    FStack.Add(TPoint.Create(aleft,atop));
  end;

  procedure TVirtualCanvas.AddItem(const aItem:TPoint);
  var
    mIndex: Integer;
  Begin
    if not FOverlap then
    Begin
      (* Only add point if not already in stack *)
      mIndex:=FStack.IndexOf(aItem);
      if mIndex<0 then
      FStack.Add(aItem);
    end else
    FStack.Add(aItem);
  end;

  Procedure TVirtualCanvas.Plot(const aLeft,aTop:Integer);
  Begin
    if not FOps then
    AddItem(aLeft,aTop) else
    FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_PLOT,
    [TPoint.Create(aLeft,aTop)]));
  end;

  Procedure TVirtualCanvas.Plot(const aPoint:TPoint);
  Begin
    if not FOps then
    AddItem(aPoint) else
    FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_PLOT,[aPoint]));
  end;

  Procedure TVirtualCanvas.Line(const x1,y1,x2,y2:Integer);
  var
    Lpixel, LMaxAxisLength: integer;
    LRatio: Real;
    dx,dy:Integer;
  begin
    if not FOps then
    Begin
      LMaxAxisLength := Max(abs(x1 - x2), abs(y1 - y2));
      for Lpixel := 0 to LMaxAxisLength do
      begin
        LRatio := Lpixel / LMaxAxisLength;
        dx:=x1 + Round((x2 - x1) * LRatio);
        dy:=y1 + Round((y2 - y1) * LRatio);
        AddItem(dx,dy);
      end;
    end else
    FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_LINE,
    [TPoint.Create(x1,y1),TPoint.Create(x2,y2)]));
  end;

  procedure TVirtualCanvas.Line(const aStart,aStop:TPoint);
  Begin
    if not FOps then
    Line(aStart.X,aStart.Y,aStop.X,aStop.Y) else
    FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_LINE,
    [aStart,aStop]));
  end;

  Procedure TVirtualCanvas.Circle(cx: Integer; cy: Integer; radius: Integer);
  var
    xpos,ypos: Integer;
    Pix, Pixels: Integer;
    x: Real;
  begin
    if radius>0 then
    Begin
      Pixels := Round( 2 * Radius * PI);
      for pix := 0 to Pixels-1 do
      begin
        x := 360 * pix / Pixels;
        xpos:=(round(cx + sin(x*pi/180)*radius));
        ypos:=(round(cy + cos(x*pi/180)*radius));
        self.AddItem(xpos,ypos);
      end;
    end;
  end;

  Procedure TVirtualCanvas.Polygon(const aPoints:Array of TPoint);
  var
    mLen: Integer;
    mIndex: Integer;
  Begin
    mLen:=length(aPoints);
    if mLen>0 then
    Begin
      if not FOps then
      Begin
        case mLen of
        1:  AddItem(aPoints[0]);
        2:  Line(aPoints[0],aPoints[1]);
        else
          begin
            for mIndex:=1 to mLen-1 do
            Line(aPoints[mIndex-1],aPoints[mIndex]);
            Line(aPoints[mLen-1],aPoints[0]);
          end;
        end;
      end else
      FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_POLY,aPoints));
    end;
  end;

  Procedure TVirtualCanvas.Rectangle(const cx,cy,wd,hd:Integer;
            const aAngle:Integer=0);
  var
    x1,y1,x2,y2,x3,y3,x4,y4:integer;
    radius,theta2:real;
    mAngle: Real;
  begin
    if (wd>0) and(hd>0) then
    Begin
      mAngle:=EnsureRange(aAngle,0,360) * PI / 180;
      radius:=sqrt(sqr(wd/2)+sqr(hd/2));
      theta2:=arctan(hd/wd);

      x1:=round(cx-radius*cos(theta2+mAngle));
      y1:=round(cy-radius*sin(theta2+mAngle));
      x2:=round(cx+radius*cos(theta2-mAngle));
      y2:=round(cy-radius*sin(theta2-mAngle));
      x3:=round(cx+radius*cos(theta2+mAngle));
      y3:=round(cy+radius*sin(theta2+mAngle));
      x4:=round(cx-radius*cos(theta2-mAngle));
      y4:=round(cy+radius*sin(theta2-mAngle));

      if not FOps then
      polygon([TPoint.Create(x1,y1),
        TPoint.Create(x2,y2),
        TPoint.Create(x3,y3),
        TPoint.Create(x4,y4)]) else
      Begin
        FInstr.Add(TVirtualCanvasOpCode.Create(CNT_VCAN_RECT,aAngle,
        [TPoint.Create(x1,y1),
        TPoint.Create(x2,y2),
        TPoint.Create(x3,y3),
        TPoint.Create(x4,y4)]));
      end;
    end;
  end;

  end.

Handle messages without forms?

Want to handle messages without creating an actual form? Send messages between a thread and your main app? Or just impress your friends by using messages to communicate between forms? This is a very handy class that i’ve used over the years. Just override “HandleMessage” to intercept and process your own messages (ps: dispatch is your friend).

  TMessageHandler = Class(TObject)
  private
    FHandle:    HWND;
  protected
    Property    Handle:HWND read FHandle;
    Procedure   HandleMessage(var message:TMessage);virtual;
  public
    Constructor Create;virtual;
    Destructor  Destroy;Override;
  End;

constructor TMessageHandler.Create;
begin
  inherited Create;
  FHandle:=AllocateHWnd(HandleMessage);
end;

destructor TMessageHandler.Destroy;
begin
  DeallocateHWnd(FHandle);
  inherited;
end;

procedure TMessageHandler.HandleMessage(var Message:TMessage);
begin
  Message.Result := DefWindowProc(FHandle, Message.Msg,
  Message.wParam, Message.lParam);
end;

Delayed non-blocking callback function

In my previous post regarding a delayed callback function under Delphi I should have pointed out that it was coded for a form-based environment. Meaning that it allows the GUI to remain responsive and other events to fire by calling application.processmessages at a regular intervals. It was indeed “blocking” in the sense that it also functions as a friendly alternative to the sleep API function.

For a complete non-blocking solution, one that truly “calls back later”, more or less a replica of the Smart Pascal callback (which essentially is the JavaScript callback), we have to add a bit more. Here is a minimalistic version of a OS friendly callback function:

  unit w3callback;

  interface

  uses System.SysUtils, Winapi.Windows, System.Generics.Collections;

  procedure w3_callback(const aCallback:TProc;ms:Integer);

  implementation

  var
  _LUT: TDictionary<UINT,TProc>;

  procedure w3_callback(const aCallback:TProc;ms:Integer);
    procedure w3_invoke(hwnd: HWND; uMsg: UINT;
              idEvent: UINT_PTR;dwTime: DWORD);stdcall;
    var
      mProc:  TProc;
    begin
      KillTimer(0,idEvent);
      if assigned(_LUT) then
      begin
        mproc:=_lut.Items[idEvent];
        _lut.Remove(idEvent);
        if assigned(mProc) then
        mproc;
      end;
    end;
  begin
    if Assigned(_LUT) then
    _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback);
  end;

  initialization
  _LUT:=TDictionary<UINT,TProc>.Create;

  finalization
  if Assigned(_LUT) then
  FreeAndNil(_LUT);

  end.

Delphi delayed callback function

When I wrote the Smart Mobile Studio RTL I added a handy function for delayed callback. Under JavaScript this is very easy to achieve and it’s also an important part of an environment that is based on events. In JavaScript everything is about events and all data is received in a non-blocking manner.

But the function is equally handy under Delphi, especially if you want something to execute “after im done with this”. It can be anything from displaying a hint on a form, to start loading data just a few seconds later. Or if you just want to add a form-friendly delay.

NOTE: This code has been replaced by a “non blocking” callback method, click here to view the latest post!

Here is the Delphi implementation of Smart Pascal’s w3_callback function (with a twist).
Note: This function is semi-blocking in the sense that it will halt execution inside the running procedure – but still allow the GUI to be responsive and events to fire. The alternative would be to spawn a thread with a synchronized re-entry.

Procedure w3_Callback(const aCallback:TProc;
          const ms:Integer);
var
  mCount: Integer;
  mThen:  TDateTime;
begin
  if assigned(application)
  and not application.Terminated then
  Begin
    try
      mCount:=0;
      mThen:=dateutils.IncMilliSecond(now,ms);
      repeat
        Sleep(0);
        Inc(mCount);
        if (mCount mod 600)=599 then
        begin
          if Assigned(Application)
          and not (application.Terminated) then
          application.ProcessMessages else
          break;
        end;
      until CompareDateTime(Now,mThen)>=0;
      if Assigned(Application)
      and not (application.Terminated)
      and Assigned(aCallback) then
      aCallback;
    except
      on exception do;
    end;
  end;
end;

How do you use it? With anonymous procedures ofcourse, like this:

  w3_Callback(
    procedure ()
    begin
      showmessage('Your helmet is ready lord vader');
    end,
    1000);