【列表7.4】程序 lockwriter 代碼。
unit LockWriterMain;
interface
uses
   SysUtils, Types, Classes, Variants, QGraphics, QControls, QForms, QDialogs,
   QStdCtrls, Libc, QExtCtrls, QTypes, QComCtrls;

type
   TLockWriterMainForm = class(TForm)
      ExitBtn: TButton;
      UpdateBtn: TButton;
      ProcLabel: TLabel;
      RecNumRBGroup: TRadioGroup;
      WaitForWriteCB: TCheckBox;
      GroupBoxl: TGroupBox;
      UpdatePanel: TPanel;
      Trigger: TTimer;
      StatusBar: TStatusBar;
      Procedure UpdateRecord;
      procedure ExitBtnClick(Sender: TObject);
      procedure FormCreate(Sender: TObject);
      procedure UpdateBtnClick(Sender: TObject);
      procedure TriggerTimer(Sender: TObject);
  private
      { Private declarations }
  public
      { Public declarations }
   end;

const
   WriteDelay = 500; { milliseconds }
   DataFileName ='/tmp/LockRegion.data';
   NumRecs = 5;
   RecLen = 20;

var
    LockWriterMainForm: TLockWriterMainForm;
    PID : pid_t;
    PIDStr : String;
    DF : Integer;
    ErrResult : Integer;

 implementation

 {SR *.xfm}

 procedure TLockWriterMainForm. UpdateRecord;
 var
    RecNum : Integer;
    RandNum : Integer;
    LockRec : TFlock;
    Buf : array[0..RecLen] of char;
    DataStr : String;
 begin
    StatusBar. SimpleText := '';
    RecNum := RecNumRBGroup. ItemIndex + 1;
{go for an exclusive lock}
LockRec.l_type:=F_WRLCK;
LockRec.l_whence := SEEK_SET;
LockRec.l_len := RecLen;
LockRec.l_pid := -1;
LockRec.l_start := RecLen * (RecNum - 1);
If WaitForWriteCB.Checked
then begin
           StatusBar.SimpleText := 'Waiting to write...';
           ErrResult := fcntl(DF, F_SETLKW, LockRec);
      end
 else ErrResult := fcntl(DF, F_SETLK, LockRec);
if ErrResult <> -1
     then begin { We've got an exclusive lock }
               StatusBar. SimpleText := ' ';
               UpdatePanel.Color := clLime;
               Application.ProcessMessages;
               RandNum := Integer(Random(32768));
               DataStr := PIDStr + ' : ' + IntToStr(RecNum)
                 + ' : ' + IntToStr(RandNum);
                if Length(DataStr) > RecLen
                 then DataStr := copy(DataStr, 1, RecLen)
                 else while Length(DataStr) < RecLen do
                              DataStr := DataStr + ' ';
                StrPCopy(Buf, DataStr);
                lseek(DF, RecLen * (RecNum - 1), SEEK_SET);
                __write(DF, Buf, RecLen);
                Sleep(WriteDelay);
                { Release the lock for this record }
                LockRec.l_type := F_UNLCK;
                LockRec.l_whence := SEEK_SET;
                LockRec.l_len := RecLen;
                LockRec.l_pid := -1;
                LockRec.l_start := RecLen * (RecNum - 1);
                fcntl(DF, F_SETLK, LockRec);
                StatusBar.SimpleText := 'Updated successfully';
               end
 else begin
            StatusBar.SimpleText := 'Not able to obtain lock';
            UpdatePanel.Color := clRed;
            Application. ProcessMessages;
            Sleep(WriteDelay);
      end;

  UpdatePanel.Color := clGreen;
end;

procedure TLockWriterMainForm. ExitBtnClick(Sender: TObject);
begin
  Close;
 end;
procedure TLockWriterMainForm. FormCreate(Sender: TObject);
var
 F : TextFile;
 i : Integer;
 s : String;
begin
  Randomize;
  PID := getpid;
  PIDStr := IntToStr(PID);
  ProcLabel.Caption := 'Process ID: ' + PIDStr;
  if not FileExists(DataFileName)
    then begin { Create the data file }
              AssignFile(F, DataFileName);
              Rewrite(F);
              for i := 1 to NumRecs do
                begin
                  s := PIDStr + ' : ' + IntToStr(i) + ' : 0';
                  while Length(s) < RecLen do s := s + '  ';
                  write(F, s);
                end; { for }
               CloseFile(F);
             end;
   DF := open(DataFileName, O_RDWR);
   if DF = -1
     then begin
               UpdateBtn. Enabled := False;
               ShowMessage('Error opening data file!');
          end;
  end;

  procedure TLockWriterMainForm,UpdateBtnClick(Sender: TObject);
  begin
   Trigger. Enabled :=True;
  end;

  procedure TLockWriterMainForm. TriggerTimer(Sender: TObject);
  begin
    Trigger. Enabled := False;
    UpdateBtn.Enabled := False;
    UpdateRecord;
    UpdateBtn. Enabled := True;
   end;
end.