unit fmTraceBack;

(**************************************************************************)

(* *)

(* PyDelphi Copyright (c) 1997 *)

(* *)

(* Morgan Martinet *)

(* 23 rue du 14 juillet *)

(* 94270 le Kremlin-Bicetre *)

(* Phone (Work): 01 47 25 70 77 *)

(* e-mail: mmm@imaginet.fr *)

(* *)

(**************************************************************************)

(* This source code is distributed with no WARRANTY, for no reason or use.*)

(* Everyone is allowed to use and change this code free for his own tasks *)

(* and projects, as long as this header and its copyright text is intact. *)

(* For changed versions of this code, which are public distributed the *)

(* following additional conditions have to be fullfilled: *)

(* 1) The header has to contain a comment on the change and the author of *)

(* it. *)

(* 2) A copy of the changed source has to be sent to the above E-Mail *)

(* address or my then valid address, if this is possible to the *)

(* author. *)

(* The second condition has the target to maintain an up to date central *)

(* version of the component. If this condition is not acceptable for *)

(* confidential or legal reasons, everyone is free to derive a component *)

(* or to generate a diff file to my or other original sources. *)

(**************************************************************************)

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls, Grids, StdCtrls, Buttons, ExtCtrls;

type

TTraceBack = class(TForm)

Panel1: TPanel;

Panel2: TPanel;

BitBtn2: TBitBtn;

BitBtn1: TBitBtn;

StringGrid1: TStringGrid;

BtnRefresh: TButton;

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure FormCreate(Sender: TObject);

procedure StringGrid1DblClick(Sender: TObject);

procedure BtnRefreshClick(Sender: TObject);

private

{ Déclarations privées }

public

{ Déclarations publiques }

procedure Clear;

procedure BuildTraceBack;

procedure FindTrace( const filename : String; lineno : Integer; const context : String );

function FindTraceInWindows( const filename : String; lineno : Integer; const context : String ) : Boolean;

procedure FindTraceInFiles( const filename : String; lineno : Integer; const context : String );

end;

procedure GetTraceBack;

var

TraceBack: TTraceBack;

implementation

uses PythonEngine, ChildWin, Misc, Main;

{$R *.DFM}

procedure GetTraceBack;

begin

if Assigned(TraceBack) then

TraceBack.BringToFront

else

begin

Screen.Cursor := crHourGlass;

try

TraceBack := TTraceBack.Create(Application);

finally

Screen.Cursor := crDefault;

end;

end;

end;

procedure TTraceBack.FormClose(Sender: TObject; var Action: TCloseAction);

begin

TraceBack := nil;

Action := caFree;

end;

procedure TTraceBack.Clear;

begin

with StringGrid1 do

begin

RowCount := 2;

FixedRows := 1;

Cells[0,0] := 'FileName';

Cells[1,0] := 'Line';

Cells[2,0] := 'Context';

Cells[0,1] := '';

Cells[1,1] := '';

Cells[2,1] := '';

end;

end;

procedure TTraceBack.BuildTraceBack;

var

tb, tb1 : PPyTraceBackObject;

filename : String;

lineno : Integer;

depth : Integer;

context : String;

limitv : PPyObject;

limit : Integer;

begin

with GetPythonEngine do

begin

// get the limit of the traceback

limit := 1000;

limitv := PySys_GetObject('tracebacklimit');

if Assigned(limitv) and PyInt_Check(limitv) then

limit := PyInt_AsLong(limitv);

with StringGrid1 do

begin

RowCount := 1;

Cells[0,0] := 'FileName';

Cells[1,0] := 'Line';

Cells[2,0] := 'Context';

tb := PPyTraceBackObject(PySys_GetObject('last_traceback'));

tb1 := tb;

depth := 0;

// Evaluate the depth of the traceback

while Assigned(tb1) do

begin

Inc(depth);

tb1 := tb1^.tb_next;

end;

// build the trace back

while Assigned(tb) do

begin

if depth <= limit then

begin

//if Py_OptimizeFlag^ <> 0 then

//tb^.tb_lineno := PyCode_Addr2Line( tb^.tb_frame^.f_code, tb^.tb_lasti );

RowCount := RowCount+1;

filename := PyString_AsString( tb^.tb_frame^.f_code^.co_filename );

lineno := tb^.tb_lineno;

context := PyString_AsString( tb^.tb_frame^.f_code^.co_name );

Cells[0, RowCount-1] := filename;

Cells[1, RowCount-1] := IntToStr(lineno);

Cells[2, RowCount-1] := context;

end;

Dec( depth );

tb := tb^.tb_next;

end;

if RowCount = 1 then

RowCount := 2;

FixedRows := 1;

end;

end;

end;

procedure TTraceBack.FormCreate(Sender: TObject);

begin

BuildTraceBack;

end;

procedure TTraceBack.StringGrid1DblClick(Sender: TObject);

begin

with StringGrid1 do

begin

if Cells[0, Row] <> '' then

begin

FindTrace( Cells[0,Row], StrToInt(Cells[1,Row]), Cells[2,Row] );

end;

end;

end;

procedure TTraceBack.FindTrace( const filename : String; lineno : Integer; const context : String );

begin

if not FindTraceInWindows( filename, lineno, context) then

FindTraceInFiles( filename, lineno, context);

end;

function TTraceBack.FindTraceInWindows( const filename : String; lineno : Integer; const context : String ) : Boolean;

var

i : Integer;

f : TMDIChild;

begin

result := False;

// Look for the good form containing our source code

for i := 0 to Screen.FormCount - 1 do

if Screen.Forms[i] is TMDIChild then

begin

f := TMDIChild(Screen.Forms[i]);

// If we find a form whose caption is the same as the Filename

if f.Caption = filename then

begin

// We found our form !

// We restore the state, in needed

if f.WindowState = wsMinimized then

f.WindowState := wsNormal;

// We bring the form to the front

f.BringToFront;

f.RichEdit1.SelStart := GetLineIndex(f.RichEdit1,lineno-1);

f.RichEdit1.SelLength := GetLineLength(f.RichEdit1,f.RichEdit1.SelStart);

GetScrollCaret( f.RichEdit1 );

// That's done !

result := True;

Exit;

end;

end;

end;

procedure TTraceBack.FindTraceInFiles( const filename : String; lineno : Integer; const context : String );

var

form : TForm;

begin

form := MainForm.CreateMDIChild(filename);

(form as TMDIChild).OpenItem(filename);

FindTraceInWindows( filename, lineno, context);

end;

procedure TTraceBack.BtnRefreshClick(Sender: TObject);

begin

BuildTraceBack;

end;

end.