How to implement a console

[Lowercase]

Sorry for this noob question...

I already visited http://www.delphi3d.net/articles/viewarticle.php?article=console.htm but I can't make it work

Do someone know a more simple tutorial ?

Thanks a lot

[jdarling]

Give this a try and see if it helps you out. Its what I use for my console windows and its been built over time.

unit uDebugger;

interface

procedure DisplayDebugWindow(UseLogFile : Boolean = False; LogFileName:String = '');
procedure ReleaseDebugWindow;

procedure DbgWriteFmt(Msg : String; const Args: array of const);
procedure DbgWriteLnFmt(Msg : String; const Args: array of const);

procedure DbgWrite(Msg : String);
procedure DbgWriteLn(Msg : String);

type
IDebugTracker=interface
['{D2ED53FC-2C16-4CAF-8AAF-27B228C43250}']
procedure StartTrack(TrackName:String);
procedure Mark(MarkName:String='');
procedure StopTrack;
end;

TDebugTracker=class(TInterfacedObject, IDebugTracker)
protected
FTrackName:String;
FTrackStart: Cardinal;
FActive : Boolean;
public
destructor Destroy; override;
procedure StartTrack(TrackName:String);
procedure Mark(MarkName:String='');
procedure StopTrack;
property TrackName : String read FTrackName;
property IsActive : Boolean read FActive;
end;

function DebugTrack(TrackName:String):IDebugTracker;

implementation

uses
Classes,
Forms,
Windows,
ShellAPI,
SysUtils;

var
DebugConsoleAllocated : Boolean;
ConsoleHandle : HWND;
DebugFile : TFileStream;

procedure DbgWrite(Msg : String);
begin
if DebugConsoleAllocated then
Write(Msg);
if Assigned(DebugFile) then
DebugFile.Write(Msg[1], Length(Msg));
end;

procedure DbgWriteLn(Msg : String);
begin
if DebugConsoleAllocated then
WriteLn(Msg);
if Assigned(DebugFile) then
begin
Msg := Msg + #13#10;
DebugFile.Write(Msg[1], Length(Msg));
end;
end;

procedure DbgWriteFmt(Msg : String; const Args: array of const);
begin
if DebugConsoleAllocated then
Write(Format(Msg, Args));
if Assigned(DebugFile) then
begin
Msg := Format(Msg, Args);
DebugFile.Write(Msg[1], Length(Msg));
end;
end;

procedure DbgWriteLnFmt(Msg : String; const Args: array of const);
begin
if DebugConsoleAllocated then
WriteLn(Format(Msg, Args));
if Assigned(DebugFile) then
begin
Msg := Format(Msg, Args);
Msg := Msg + #13#10;
DebugFile.Write(Msg[1], Length(Msg));
end;
end;

function MyGetConsoleHandle : HWND;
var
cTitle : Array[0..MAX_PATH] of Char;
begin
GetConsoleTitle(cTitle, MAX_PATH);
result := FindWindowEx(0,0,'ConsoleWindowClass', cTitle);
end;

procedure DisplayDebugWindow(UseLogFile : Boolean = False; LogFileName:String = '');
begin
if DebugConsoleAllocated then
exit;
if AllocConsole then
begin
ConsoleHandle := GetStdHandle(STD_OUTPUT_HANDLE);
SetConsoleTextAttribute( ConsoleHandle,
FOREGROUND_BLUE or
FOREGROUND_GREEN or
FOREGROUND_RED or
FOREGROUND_INTENSITY
);
ConsoleHandle := MyGetConsoleHandle;
if Screen.MonitorCount > 1 then
SetWindowPos(ConsoleHandle, HWND_TOP, Screen.Monitors[1].Left, Screen.Monitors[1].Top, 800, 600, SWP_NOSIZE)
else
SetWindowPos(ConsoleHandle, HWND_TOP, Screen.Monitors[0].Left, Screen.Monitors[0].Top, 800, 600, SWP_NOSIZE);
DebugConsoleAllocated := true;
if (UseLogFile) then
begin
if LogFileName = '' then
DebugFile := TFileStream.Create(ChangeFileExt(ParamStr(0), '.log'), fmCreate)
else
begin
if (Pos(':\', LogFileName) = 0) or
(Pos('\\', LogFileName) = 0) then
LogFileName := ExtractFilePath(ParamStr(0)) + LogFileName;
DebugFile := TFileStream.Create(LogFileName, fmCreate);
end;
DebugFile.Position := DebugFile.Size;
end
else
DebugFile := nil;
end
else
DebugConsoleAllocated := false;
end;

procedure ReleaseDebugWindow;
begin
DebugConsoleAllocated := false;
FreeConsole;
DebugFile.Free;
DebugFile := nil;
end;

{ TDebugTracker }

destructor TDebugTracker.Destroy;
begin
if FActive then
StopTrack;
inherited;
end;

procedure TDebugTracker.Mark(MarkName: String);
var
CurrTick : Cardinal;
begin
if not FActive then
exit;
CurrTick := GetTickCount;
DbgWriteLnFmt('%d:%d %s Mark %s', [CurrTick, CurrTick-FTrackStart, FTrackName, MarkName]);
end;

procedure TDebugTracker.StartTrack(TrackName: String);
begin
DisplayDebugWindow;
FTrackName := TrackName;
FTrackStart:= GetTickCount;
FActive := true;
DbgWriteLnFmt('%d:0 %s StartTrack', [GetTickCount, FTrackName]);
end;

procedure TDebugTracker.StopTrack;
var
CurrTick : Cardinal;
begin
if not FActive then
exit;
CurrTick := GetTickCount;
DbgWriteLnFmt('%d:%d %s StopTrack', [CurrTick, CurrTick-FTrackStart, FTrackName]);
FActive := false;
end;

function DebugTrack(TrackName:String):IDebugTracker;
begin
result := TDebugTracker.Create;
result.StartTrack(TrackName);
end;

initialization
DebugConsoleAllocated := false;

finalization
ReleaseDebugWindow;

end.

[Lowercase]

thanks for the tip !

If i'm right, your program allocates a window console (cmd.exe) and you can log all your events on it. But if I run my opengl program fullscreen, I can't see it.

I was thinking about a Quake style console with command parsing (so you can access it directly from your program)

[jdarling]

Well, your right about what mine does. I run dual monitors so it allocates it and moves to the 2nd screen. The logger is not necessary, its just there in case it becomes useful.

For a single screen implementation I have no idea. I hate it when the console is built into the game itself, so I've went with a 2nd console window. What I basically do is:


uses
uDebugger;

procedure InitGame(RunInDebugMode : Boolean = false; UseLogFile : Boolean = false);
begin
if RunInDebugMode then
begin
DisplayDebugWindow(UseLogFile);
end;
// Rest of initialization stuff here
// ...
// Don't have to test for a window existing, if it doesn't nothing will happen.
DbgWriteLn('Engine Initialized: ' + DateTimeToStr(Now));
end;

finalization
ReleaseDebugWindow;
end;

In the code that was shown on the page you provided there is a minor mistake. Its worded properly in the paragraph that describes it, but displayed in-correctly. It should be as follows:

type
TCommand = procedure (var params: String);
TCommandClass = class(TObject)
public
procedure CallMethod(name: String; var params: String);
published // VERY IMPORTANT
procedure VideoMode(var params: String);
procedure Pause(var params: String);
procedure ShowScores(var params: String);
end;

implementation

procedure TCommandClass.CallMethod(name: String; var params: String);
var
cmd: TCommand;
begin
@cmd := MethodAddress(name);
cmd(params);
end;

end.

If you want, post up a simple sample of your code not working and I'm sure that someone on this board can help.