dexed/src/u_blame.pas

unit u_blame;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
  Buttons, ghashmap, process, Clipbrd,
  u_common, u_interfaces, u_observer, u_widget,
  u_synmemo, u_stringrange, u_sharedres;

type

  TLineData = record
    // the previous git hash
    hash: string;
    // if file has ever moved
    filename: string;
    // data, author or prev
    info: string;
  end;

  TBlameDataKind = (
    bdkNone,  // no yet computed
    bdkFirst, // initial blame on HEAD
    bdkBlame // display in a dedicated editor
  );

  TEditorData = class
  private
    // if this is a standard editor or one opened to start blaming
    kind: TBlameDataKind;
    // the filename in git
    filename: string;
    // current revision
    currHash: string;
    // previous revision and fname for each line
    lineData: array of TLineData;
  end;

  TEditorToData = specialize THashmap<TDexedMemo, TEditorData, TObjectHash>;

  { TBlameWidget }

  TBlameWidget = class(TDexedWidget, IDocumentObserver, IProjectObserver)
    btnBlame: TButton;
    btnCpyPrevHash: TSpeedButton;
    btnLogCurr: TSpeedButton;
    btnLogPrev: TSpeedButton;
    grpGen: TGroupBox;
    Panel4: TPanel;
    grpLine: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Panel1: TPanel;
    Label4: TLabel;
    lblFname: TStaticText;
    Panel2: TPanel;
    Panel3: TPanel;
    lblDispRev: TStaticText;
    lblPrevRev: TStaticText;
    lblAuthDate: TStaticText;
    btnCpyCurrHash: TSpeedButton;
    Timer1: TTimer;
    procedure btnBlameClick(Sender: TObject);
    procedure btnCpyCurrHashClick(Sender: TObject);
    procedure btnCpyPrevHashClick(Sender: TObject);
    procedure btnLogCurrClick(Sender: TObject);
    procedure btnLogPrevClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    fEditors: TEditorToData;
    fDocData: TEditorData;
    fDoc: TDExedMemo;
    fProj: ICommonProject;
    function getGitCwd(): string;
    procedure showLog(const hash: string);
    function checkTool(var exename: string): boolean;
  protected
    procedure setVisible(Value: Boolean); override;
    procedure setToolBarFlat(value: boolean); override;
  public
    constructor create(aOwner: TComponent); override;
    destructor destroy(); override;

    procedure docNew(document: TDexedMemo);
    procedure docFocused(document: TDexedMemo);
    procedure docChanged(document: TDexedMemo);
    procedure docClosing(document: TDexedMemo);

    procedure projNew(project: ICommonProject);
    procedure projChanged(project: ICommonProject);
    procedure projClosing(project: ICommonProject);
    procedure projFocused(project: ICommonProject);
    procedure projCompiling(project: ICommonProject);
    procedure projCompiled(project: ICommonProject; success: boolean);

    procedure updateView();

    procedure blameToData(gitLines: TStrings; blameLines: TStrings);
    procedure blameBegin();
    procedure blameContinue();

  end;

implementation
{$R *.lfm}

constructor TBlameWidget.create(aOwner: TComponent);
begin
  inherited;
  fEditors := TEditorToData.create();
  toolbarVisible:= false;
  case GetIconScaledSize of
    iss16:
    begin
      AssignPng(btnCpyCurrHash, 'COPY');
      AssignPng(btnCpyPrevHash, 'COPY');
      AssignPng(btnLogCurr, 'GIT');
      AssignPng(btnLogPrev, 'GIT');
    end;
    iss24:
    begin
      AssignPng(btnCpyCurrHash, 'COPY24');
      AssignPng(btnCpyPrevHash, 'COPY24');
      AssignPng(btnLogCurr, 'GIT24');
      AssignPng(btnLogPrev, 'GIT24');
    end;
    iss32:
    begin
      AssignPng(btnCpyCurrHash, 'COPY32');
      AssignPng(btnCpyPrevHash, 'COPY32');
      AssignPng(btnLogCurr, 'GIT32');
      AssignPng(btnLogPrev, 'GIT32');
    end;
  end;
  EntitiesConnector.addObserver(self);
end;

destructor TBlameWidget.destroy();
begin
  fEditors.free();
  inherited;
end;

procedure TBlameWidget.setVisible(Value: Boolean);
begin
  inherited SetVisible(value);
  if Timer1.isAssigned then
    Timer1.Enabled := value;
end;

procedure TBlameWidget.setToolBarFlat(value: boolean);
begin
  inherited;
  btnLogCurr.Flat := value;
  btnCpyCurrHash.Flat := value;
  btnLogPrev.Flat := value;
  btnCpyPrevHash.Flat := value;
end;

procedure TBlameWidget.docNew(document: TDexedMemo);
begin
end;

procedure TBlameWidget.docFocused(document: TDexedMemo);
begin
  fDoc := document;
  if fEditors.contains(document) then
  begin
    fDocData := fEditors[document];
  end else
  begin
    fDocData := TEditorData.Create;
    fEditors.insert(fDoc, fDocData);
  end;
end;

procedure TBlameWidget.docChanged(document: TDexedMemo);
begin
end;

procedure TBlameWidget.docClosing(document: TDexedMemo);
var
  closingData: TEditorData = nil;
begin
  if fEditors.contains(document) then
  begin
    closingData := fEditors[document];
    closingData.Free();
    fEditors.delete(document);
  end;
  if fDoc = document then
    fDoc := nil;
end;

procedure TBlameWidget.projNew(project: ICommonProject);
begin
end;

procedure TBlameWidget.projChanged(project: ICommonProject);
begin
end;

procedure TBlameWidget.projClosing(project: ICommonProject);
begin
  if project = fProj then
    fProj := nil;
end;

procedure TBlameWidget.projFocused(project: ICommonProject);
begin
  fProj := project;
end;

procedure TBlameWidget.projCompiling(project: ICommonProject);
begin
end;

procedure TBlameWidget.projCompiled(project: ICommonProject; success: boolean);
begin
end;

procedure TBlameWidget.blameToData(gitLines: TStrings; blameLines: TStrings);
var
  i   : integer;
  line: string;
  rng : TStringRange = (ptr:nil; pos:0; len:0);
  tmp : string;
begin
  setLength(fDocData.lineData, gitLines.Count);
  for i := 0 to gitLines.count-1 do
  begin
    line:= gitLines[i];
    rng := TStringRange.create(line);
    // hash
    tmp := rng.takeUntil(' ').yield().ToUpper;
    fDocData.lineData[i].hash := tmp;
    rng.popFront();
    // optional filename
    if rng.front() <> '(' then
    begin
      tmp := rng.takeUntil('(').yield();
      tmp := TrimRight(tmp);
      fDocData.lineData[i].filename := tmp;
      rng.popFront();
    end;
    // date, author
    tmp := rng.takeUntil(')').yield();
    fDocData.lineData[i].info := tmp;
    rng.popFront;
    rng.popFront;
    // code
    if blameLines.isAssigned() then
    begin
      tmp := rng.takeUntil([#13,#10]).yield();
      blameLines.Add(tmp);
    end;
  end;
end;

function TBlameWidget.getGitCwd():string;
var
  old: string = '';
begin
  result := '';
  if assigned(fProj) then
  begin
    result := fProj.filename.extractFileDir;
  end
  else
  if fDoc.isAssigned then
  begin
    result := fDoc.fileName;
    while true do
    begin
      result := result.extractFileDir;
      if result = old then
        exit;
      if (result + DirectorySeparator + '.git').dirExists then
        exit;
      old := result;
    end;
  end;
end;

function TBlameWidget.checkTool(var exename: string): boolean;
begin
  exename := exeFullName('git' + exeExt);
  result  := exename.fileExists();
  if not result then
    getMessageDisplay().message('cannot locate the `git` executable', nil, amcApp, amkErr);
end;

procedure TBlameWidget.blameBegin();
var
  p: TProcess = nil;
  s: TStringList = nil;
  d: IMessagesDisplay = nil;
  i: integer;
  g: string = '';
begin
  if fDoc.isNotAssigned or not checkTool(g) then
    exit;
  p := TProcess.create(nil);
  s := TStringList.Create();
  try
    p.Executable:= g;
    p.Options := [poUsePipes, poNoConsole];
    p.ShowWindow:= swoHIDE;
    p.CurrentDirectory:= getGitCwd();
    p.Parameters.AddStrings([ 'blame', fDoc.fileName]);
    p.execute();
    processOutputToStrings(p,s);
    while p.Running do ;
    if p.ExitCode = 0 then
    begin
      fDocData.filename := fDoc.fileName;
      blameToData(s,nil);
      fDocData.kind := bdkFirst;
    end else
    begin
      d := getMessageDisplay();
      s.LoadFromStream(p.Stderr);
      for i := 0 to s.Count-1 do
        d.message(s[i], fProj, amcMisc, amkAuto);
    end;
  finally
    p.free();
    s.free();
  end;
end;

procedure TBlameWidget.blameContinue();
var
  newDoc: TDexedMemo = nil;
  oldDoc: TDexedMemo = nil;
  p: TProcess = nil;
  s: TStringList = nil;
  d: TLineData;
  m: IMessagesDisplay = nil;
  n: string = '';
  h: string;
  i: integer;
  g: string = '';
begin
  if fDoc.isNotAssigned or not checkTool(g) then
    exit;
  oldDoc := fDoc;
  d := fDocData.lineData[fDoc.CaretY-1];
  h := d.hash;
  if d.filename.isNotEmpty then
    n := d.filename
  else if fDocData.kind = bdkFirst then
    n := fDoc.fileName
  else
    n := fDocData.filename;

  p := TProcess.create(nil);
  s := TStringList.Create();
  try
    p.Executable := exeFullName('git' + exeExt);
    p.Options    := [poUsePipes, poNoConsole];
    p.ShowWindow := swoHIDE;
    p.CurrentDirectory:= getGitCwd();
    p.Parameters.AddStrings([ 'blame', n, h]);
    p.execute();
    processOutputToStrings(p,s);
    while p.Running do ;
    if p.ExitCode = 0 then
    begin
      newDoc := TDexedMemo.Create(nil);
      blameToData(s,newDoc.Lines);
      fDocData.kind     := bdkBlame;
      fDocData.currHash := h;
      fDocData.filename := n;
      newDoc.ReadOnly   := true;
      newDoc.setHighligtherFrom(oldDoc);
      getMultiDocHandler().forceCaption(newDoc, '<blame-only view>');
    end else
    begin
      m := getMessageDisplay();
      s.LoadFromStream(p.Stderr);
      for i := 0 to s.Count-1 do
        m.message(s[i], fProj, amcMisc, amkAuto);
    end;
  finally
    p.free();
    s.free();
  end;
end;

procedure TBlameWidget.updateView();
var
  d: TLineData;
begin
  if fDocData.isNotAssigned or (not visible) or fDoc.isNotAssigned then
    exit;
  if fDocData.kind = bdkNone then
  begin
    lblFname.Caption   := fDoc.fileName;
    lblDispRev.Caption := 'HEAD';
    lblPrevRev.Caption := 'N/A';
    lblAuthDate.Caption:= 'N/A';
    btnBlame.Caption   := 'Collect initial data';
  end else
  begin
    if fDocData.kind = bdkFirst then
    begin
      lblFname.Caption  := fDoc.fileName;
      lblDispRev.Caption:= 'HEAD';
    end else
    begin
      lblFname.Caption  := fDocData.fileName;
      lblDispRev.Caption:= fDocData.currHash;
    end;
    d := fDocData.lineData[fDoc.CaretY-1];
    lblAuthDate.Caption := d.info;
    if d.hash <> fDocData.currHash then
    begin
      btnBlame.Enabled   := true;
      btnBlame.Caption   := format('Open blame view for %s', [d.hash]);
      lblPrevRev.Caption := d.hash;
    end else
    begin
      btnBlame.Enabled   := false;
      btnBlame.Caption   := 'Open blame';
      lblPrevRev.Caption := 'N/A (initial commit)';
    end;
  end;
end;

procedure TBlameWidget.btnBlameClick(Sender: TObject);
begin
  if fDocData.isNotAssigned then
    exit;
  if fDocData.kind = bdkNone then
    blameBegin()
  else
    blameContinue();
end;

procedure TBlameWidget.btnCpyCurrHashClick(Sender: TObject);
begin
  if fDocData.isAssigned then
    Clipboard.AsText := fDocData.currHash;
end;

procedure TBlameWidget.btnCpyPrevHashClick(Sender: TObject);
begin
  if fDocData.isAssigned and fDoc.isAssigned then
    Clipboard.AsText := fDocData.lineData[fDoc.CaretY-1].hash;
end;

procedure TBlameWidget.btnLogCurrClick(Sender: TObject);
begin
  if fDocData.isAssigned then
    showLog(fDocData.currHash);
end;

procedure TBlameWidget.btnLogPrevClick(Sender: TObject);
begin
  if fDocData.isAssigned and fDoc.isAssigned then
    showLog(fDocData.lineData[fDoc.CaretY-1].hash);
end;

procedure TBlameWidget.showLog(const hash: string);
var
  p: TProcess;
  g: TStringList;
begin
  p := TProcess.Create(nil);
  g := TStringList.Create;
  try
    p.Executable := exeFullName('git' + exeExt);
    p.Options    := [poUsePipes, poNoConsole];
    p.ShowWindow := swoHIDE;
    p.CurrentDirectory:= getGitCwd();
    p.Parameters.AddStrings([ 'log', hash, '-n1', '--pretty=full']);
    p.execute();
    processOutputToStrings(p,g);
    while p.Running do ;
    if p.ExitCode = 0 then
    begin
      showMessage(g.Text);
    end;
  finally
    p.free;
    g.free;
  end;
end;

procedure TBlameWidget.Timer1Timer(Sender: TObject);
begin
  updateView;
end;

end.