• R/O
  • SSH
  • HTTPS

dzbdslauncher: 提交


Commit MetaInfo

修訂48 (tree)
時間2022-01-22 20:49:04
作者dummzeuch

Log Message

(empty log message)

Change Summary

差異

--- tags/1.0.8/src/Velthuis.Console.pas (nonexistent)
+++ tags/1.0.8/src/Velthuis.Console.pas (revision 48)
@@ -0,0 +1,941 @@
1+{ }
2+{ File: Velthuis.Console.pas }
3+{ Function: Console unit, similar to the Crt unit in Turbo Pascal. }
4+{ Language: Delphi 5 and above }
5+{ Author: Rudolph Velthuis }
6+{ Copyright: (c) 2006,2008 Rudy Velthuis }
7+{ Disclaimer: This code is freeware. All rights are reserved. }
8+{ This code is provided as is, expressly without a warranty }
9+{ of any kind. You use it at your own risk. }
10+{ }
11+{ If you use this code, please credit me. }
12+{ }
13+// taken from https://github.com/rvelthuis/Consoles
14+// -- 2020-02-29 twm
15+
16+unit Velthuis.Console;
17+
18+{$IFDEF CONDITIONALEXPRESSIONS}
19+ {$IF CompilerVersion >= 17.0}
20+ {$DEFINE INLINES}
21+ {$IFEND}
22+ {$IF RTLVersion >= 14.0}
23+ {$DEFINE HASERROUTPUT}
24+ {$IFEND}
25+{$ENDIF}
26+
27+interface
28+
29+uses Windows;
30+
31+const
32+ // Background and foreground colors
33+ Black = 0;
34+ Blue = 1;
35+ Green = 2;
36+ Cyan = 3;
37+ Red = 4;
38+ Magenta = 5;
39+ Brown = 6;
40+ LightGray = 7;
41+
42+ // Foreground colors
43+ DarkGray = 8;
44+ LightBlue = 9;
45+ LightGreen = 10;
46+ LightCyan = 11;
47+ LightRed = 12;
48+ LightMagenta = 13;
49+ Yellow = 14;
50+ White = 15;
51+
52+ // Blink attribute, to be or-ed with background colors.
53+ Blink = 128;
54+
55+ // Text modes:
56+ BW40 = 0; // 40x25 B/W on Color Adapter
57+ CO40 = 1; // 40x25 Color on Color Adapter
58+ BW80 = 2; // 80x25 B/W on Color Adapter
59+ CO80 = 3; // 80x25 Color on Color Adapter
60+ Mono = 7; // 80x25 on Monochrome Adapter
61+ Font8x8 = 256; // Add-in for ROM font
62+
63+ // Mode constants for 3.0 compatibility of original CRT unit }
64+ C40 = CO40;
65+ C80 = CO80;
66+
67+
68+// Turbo/Borland Pascal Crt routines:
69+
70+// Waits for keypress and returns the key pressed. If the key is not an ASCII
71+// key, #0 is returned, and a successive ReadKey will give the extended key
72+// code of the key.
73+function ReadKey: Char;
74+
75+// Checks whether a key was pressed.
76+function KeyPressed: Boolean;
77+
78+// Puts the cursor at the given coordinates on the screen.
79+procedure GotoXY(X, Y: Smallint);
80+
81+// Returns the current X position of the cursor.
82+function WhereX: Integer;
83+
84+// Returns the current Y position of the cursor.
85+function WhereY: Integer;
86+
87+// Sets text foreground color.
88+procedure TextColor(Color: Byte); overload;
89+
90+// Gets text forground color.
91+function TextColor: Byte; overload;
92+
93+// Sets text background color.
94+procedure TextBackground(Color: Byte); overload;
95+
96+// Gets text background color.
97+function TextBackground: Byte; overload;
98+
99+// Sets text mode.
100+procedure TextMode(Mode: Word);
101+
102+// Sets text colors to low intensity
103+procedure LowVideo;
104+
105+// Sets text colors to high intensity
106+procedure HighVideo;
107+
108+// Sets text attribute to value at startup.
109+procedure NormVideo;
110+
111+// Clears the entire screen, or, if a window is set, the entire window,
112+// in the current background color.
113+procedure ClrScr;
114+
115+// Clears until the end of the line, in the current background color.
116+procedure ClrEol;
117+
118+// Inserts a line at the current cursor position.
119+procedure InsLine;
120+
121+// Deletes the line at the current cursor position.
122+procedure DelLine;
123+
124+// Sets a window, into which all successive output will go. You can reset the
125+// window to full screen by calling Window with a zero or negative value
126+// for Left.
127+procedure Window(Left, Top, Right, Bottom: Integer);
128+
129+// Displays message and waits for the next key press. Displays key
130+// and returns.
131+function Pause(const Msg: string = ''): Char;
132+
133+type
134+ // Plays a sound at the given frequency (in Herz).
135+ TSoundProc = procedure(Frequency: Smallint);
136+
137+ // Stops the sound started with Sound.
138+ TNoSoundProc = procedure;
139+
140+ // Delays for the given amount of milliseconds, or as close as possible.
141+ TDelayProc = procedure(Millisecs: Integer);
142+
143+ // Plays a sound at the given frequency (in Hz) and duration (in ms).
144+ TBeepProc = procedure(Frequency, Duration: Smallint);
145+
146+var
147+ Sound: TSoundProc;
148+ NoSound: TNoSoundProc;
149+ Delay: TDelayProc;
150+ Beep: TBeepProc;
151+
152+// Additional routines:
153+
154+function ScreenWidth: Smallint;
155+function ScreenHeight: Smallint;
156+function BufferWidth: Smallint;
157+function BufferHeight: Smallint;
158+
159+var
160+ TextWindow: TSmallRect;
161+ TextAttr: Byte;
162+ DefaultAttr: Byte;
163+ ScreenMode: Byte;
164+ BufferSize: TCoord;
165+ ScreenSize: TCoord;
166+ StdIn, StdOut: THandle;
167+ StdErr: THandle;
168+ LastMode: Word;
169+ WindMin: Word;
170+ WindMax: Word;
171+ CheckBreak: Boolean;
172+
173+implementation
174+
175+uses SysUtils;
176+
177+type
178+ PKey = ^TKey;
179+ TKey = record
180+ KeyCode: Smallint;
181+ Normal: Smallint;
182+ Shift: Smallint;
183+ Ctrl: Smallint;
184+ Alt: Smallint;
185+ end;
186+
187+const
188+ CKeys: array[0..88] of TKey = (
189+ (KeyCode: VK_BACK; Normal: $8; Shift: $8; Ctrl: $7F; Alt: $10E; ),
190+ (KeyCode: VK_TAB; Normal: $9; Shift: $10F; Ctrl: $194; Alt: $1A5; ),
191+ (KeyCode: VK_RETURN; Normal: $D; Shift: $D; Ctrl: $A; Alt: $1A6),
192+ (KeyCode: VK_ESCAPE; Normal: $1B; Shift: $1B; Ctrl: $1B; Alt: $101),
193+ (KeyCode: VK_SPACE; Normal: $20; Shift: $20; Ctrl: $103; Alt: $20),
194+ (KeyCode: Ord('0'); Normal: Ord('0'); Shift: Ord(')'); Ctrl: - 1; Alt: $181),
195+ (KeyCode: Ord('1'); Normal: Ord('1'); Shift: Ord('!'); Ctrl: - 1; Alt: $178),
196+ (KeyCode: Ord('2'); Normal: Ord('2'); Shift: Ord('@'); Ctrl: $103; Alt: $179),
197+ (KeyCode: Ord('3'); Normal: Ord('3'); Shift: Ord('#'); Ctrl: - 1; Alt: $17A),
198+ (KeyCode: Ord('4'); Normal: Ord('4'); Shift: Ord('$'); Ctrl: - 1; Alt: $17B),
199+ (KeyCode: Ord('5'); Normal: Ord('5'); Shift: Ord('%'); Ctrl: - 1; Alt: $17C),
200+ (KeyCode: Ord('6'); Normal: Ord('6'); Shift: Ord('^'); Ctrl: $1E; Alt: $17D),
201+ (KeyCode: Ord('7'); Normal: Ord('7'); Shift: Ord('&'); Ctrl: - 1; Alt: $17E),
202+ (KeyCode: Ord('8'); Normal: Ord('8'); Shift: Ord('*'); Ctrl: - 1; Alt: $17F),
203+ (KeyCode: Ord('9'); Normal: Ord('9'); Shift: Ord('('); Ctrl: - 1; Alt: $180),
204+ (KeyCode: Ord('A'); Normal: Ord('a'); Shift: Ord('A'); Ctrl: $1; Alt: $11E),
205+ (KeyCode: Ord('B'); Normal: Ord('b'); Shift: Ord('B'); Ctrl: $2; Alt: $130),
206+ (KeyCode: Ord('C'); Normal: Ord('c'); Shift: Ord('C'); Ctrl: $3; Alt: $12E),
207+ (KeyCode: Ord('D'); Normal: Ord('d'); Shift: Ord('D'); Ctrl: $4; Alt: $120),
208+ (KeyCode: Ord('E'); Normal: Ord('e'); Shift: Ord('E'); Ctrl: $5; Alt: $112),
209+ (KeyCode: Ord('F'); Normal: Ord('f'); Shift: Ord('F'); Ctrl: $6; Alt: $121),
210+ (KeyCode: Ord('G'); Normal: Ord('g'); Shift: Ord('G'); Ctrl: $7; Alt: $122),
211+ (KeyCode: Ord('H'); Normal: Ord('h'); Shift: Ord('H'); Ctrl: $8; Alt: $123),
212+ (KeyCode: Ord('I'); Normal: Ord('i'); Shift: Ord('I'); Ctrl: $9; Alt: $117),
213+ (KeyCode: Ord('J'); Normal: Ord('j'); Shift: Ord('J'); Ctrl: $A; Alt: $124),
214+ (KeyCode: Ord('K'); Normal: Ord('k'); Shift: Ord('K'); Ctrl: $B; Alt: $125),
215+ (KeyCode: Ord('L'); Normal: Ord('l'); Shift: Ord('L'); Ctrl: $C; Alt: $126),
216+ (KeyCode: Ord('M'); Normal: Ord('m'); Shift: Ord('M'); Ctrl: $D; Alt: $132),
217+ (KeyCode: Ord('N'); Normal: Ord('n'); Shift: Ord('N'); Ctrl: $E; Alt: $131),
218+ (KeyCode: Ord('O'); Normal: Ord('o'); Shift: Ord('O'); Ctrl: $F; Alt: $118),
219+ (KeyCode: Ord('P'); Normal: Ord('p'); Shift: Ord('P'); Ctrl: $10; Alt: $119),
220+ (KeyCode: Ord('Q'); Normal: Ord('q'); Shift: Ord('Q'); Ctrl: $11; Alt: $110),
221+ (KeyCode: Ord('R'); Normal: Ord('r'); Shift: Ord('R'); Ctrl: $12; Alt: $113),
222+ (KeyCode: Ord('S'); Normal: Ord('s'); Shift: Ord('S'); Ctrl: $13; Alt: $11F),
223+ (KeyCode: Ord('T'); Normal: Ord('t'); Shift: Ord('T'); Ctrl: $14; Alt: $114),
224+ (KeyCode: Ord('U'); Normal: Ord('u'); Shift: Ord('U'); Ctrl: $15; Alt: $116),
225+ (KeyCode: Ord('V'); Normal: Ord('v'); Shift: Ord('V'); Ctrl: $16; Alt: $12F),
226+ (KeyCode: Ord('W'); Normal: Ord('w'); Shift: Ord('W'); Ctrl: $17; Alt: $111),
227+ (KeyCode: Ord('X'); Normal: Ord('x'); Shift: Ord('X'); Ctrl: $18; Alt: $12D),
228+ (KeyCode: Ord('Y'); Normal: Ord('y'); Shift: Ord('Y'); Ctrl: $19; Alt: $115),
229+ (KeyCode: Ord('Z'); Normal: Ord('z'); Shift: Ord('Z'); Ctrl: $1A; Alt: $12C),
230+ (KeyCode: VK_PRIOR; Normal: $149; Shift: $149; Ctrl: $184; Alt: $199),
231+ (KeyCode: VK_NEXT; Normal: $151; Shift: $151; Ctrl: $176; Alt: $1A1),
232+ (KeyCode: VK_END; Normal: $14F; Shift: $14F; Ctrl: $175; Alt: $19F),
233+ (KeyCode: VK_HOME; Normal: $147; Shift: $147; Ctrl: $177; Alt: $197),
234+ (KeyCode: VK_LEFT; Normal: $14B; Shift: $14B; Ctrl: $173; Alt: $19B),
235+ (KeyCode: VK_UP; Normal: $148; Shift: $148; Ctrl: $18D; Alt: $198),
236+ (KeyCode: VK_RIGHT; Normal: $14D; Shift: $14D; Ctrl: $174; Alt: $19D),
237+ (KeyCode: VK_DOWN; Normal: $150; Shift: $150; Ctrl: $191; Alt: $1A0),
238+ (KeyCode: VK_INSERT; Normal: $152; Shift: $152; Ctrl: $192; Alt: $1A2),
239+ (KeyCode: VK_DELETE; Normal: $153; Shift: $153; Ctrl: $193; Alt: $1A3),
240+ (KeyCode: VK_NUMPAD0; Normal: Ord('0'); Shift: $152; Ctrl: $192; Alt: - 1),
241+ (KeyCode: VK_NUMPAD1; Normal: Ord('1'); Shift: $14F; Ctrl: $175; Alt: - 1),
242+ (KeyCode: VK_NUMPAD2; Normal: Ord('2'); Shift: $150; Ctrl: $191; Alt: - 1),
243+ (KeyCode: VK_NUMPAD3; Normal: Ord('3'); Shift: $151; Ctrl: $176; Alt: - 1),
244+ (KeyCode: VK_NUMPAD4; Normal: Ord('4'); Shift: $14B; Ctrl: $173; Alt: - 1),
245+ (KeyCode: VK_NUMPAD5; Normal: Ord('5'); Shift: $14C; Ctrl: $18F; Alt: - 1),
246+ (KeyCode: VK_NUMPAD6; Normal: Ord('6'); Shift: $14D; Ctrl: $174; Alt: - 1),
247+ (KeyCode: VK_NUMPAD7; Normal: Ord('7'); Shift: $147; Ctrl: $177; Alt: - 1),
248+ (KeyCode: VK_NUMPAD8; Normal: Ord('8'); Shift: $148; Ctrl: $18D; Alt: - 1),
249+ (KeyCode: VK_NUMPAD9; Normal: Ord('9'); Shift: $149; Ctrl: $184; Alt: - 1),
250+ (KeyCode: VK_MULTIPLY; Normal: Ord('*'); Shift: Ord('*'); Ctrl: $196; Alt: $137),
251+ (KeyCode: VK_ADD; Normal: Ord('+'); Shift: Ord('+'); Ctrl: $190; Alt: $14E),
252+ (KeyCode: VK_SUBTRACT; Normal: Ord('-'); Shift: Ord('-'); Ctrl: $18E; Alt: $14A),
253+ (KeyCode: VK_DECIMAL; Normal: Ord('.'); Shift: Ord('.'); Ctrl: $153; Alt: $193),
254+ (KeyCode: VK_DIVIDE; Normal: Ord('/'); Shift: Ord('/'); Ctrl: $195; Alt: $1A4),
255+ (KeyCode: VK_F1; Normal: $13B; Shift: $154; Ctrl: $15E; Alt: $168),
256+ (KeyCode: VK_F2; Normal: $13C; Shift: $155; Ctrl: $15F; Alt: $169),
257+ (KeyCode: VK_F3; Normal: $13D; Shift: $156; Ctrl: $160; Alt: $16A),
258+ (KeyCode: VK_F4; Normal: $13E; Shift: $157; Ctrl: $161; Alt: $16B),
259+ (KeyCode: VK_F5; Normal: $13F; Shift: $158; Ctrl: $162; Alt: $16C),
260+ (KeyCode: VK_F6; Normal: $140; Shift: $159; Ctrl: $163; Alt: $16D),
261+ (KeyCode: VK_F7; Normal: $141; Shift: $15A; Ctrl: $164; Alt: $16E),
262+ (KeyCode: VK_F8; Normal: $142; Shift: $15B; Ctrl: $165; Alt: $16F),
263+ (KeyCode: VK_F9; Normal: $143; Shift: $15C; Ctrl: $166; Alt: $170),
264+ (KeyCode: VK_F10; Normal: $144; Shift: $15D; Ctrl: $167; Alt: $171),
265+ (KeyCode: VK_F11; Normal: $185; Shift: $187; Ctrl: $189; Alt: $18B),
266+ (KeyCode: VK_F12; Normal: $186; Shift: $188; Ctrl: $18A; Alt: $18C),
267+ (KeyCode: $DC; Normal: Ord('\'); Shift: Ord('|'); Ctrl: $1C; Alt: $12B),
268+ (KeyCode: $BF; Normal: Ord('/'); Shift: Ord('?'); Ctrl: - 1; Alt: $135),
269+ (KeyCode: $BD; Normal: Ord('-'); Shift: Ord('_'); Ctrl: $1F; Alt: $182),
270+ (KeyCode: $BB; Normal: Ord('='); Shift: Ord('+'); Ctrl: - 1; Alt: $183),
271+ (KeyCode: $DB; Normal: Ord('['); Shift: Ord('{'); Ctrl: $1B; Alt: $11A),
272+ (KeyCode: $DD; Normal: Ord(']'); Shift: Ord('}'); Ctrl: $1D; Alt: $11B),
273+ (KeyCode: $BA; Normal: Ord(';'); Shift: Ord(':'); Ctrl: - 1; Alt: $127),
274+ (KeyCode: $DE; Normal: Ord(''''); Shift: Ord('"'); Ctrl: - 1; Alt: $128),
275+ (KeyCode: $BC; Normal: Ord(','); Shift: Ord('<'); Ctrl: - 1; Alt: $133),
276+ (KeyCode: $BE; Normal: Ord('.'); Shift: Ord('>'); Ctrl: - 1; Alt: $134),
277+ (KeyCode: $C0; Normal: Ord('`'); Shift: Ord('~'); Ctrl: - 1; Alt: $129)
278+ );
279+
280+var
281+ ExtendedChar: Char = #0;
282+
283+function FindKeyCode(KeyCode: Smallint): PKey; {$IFDEF INLINES}inline;{$ENDIF}
284+var
285+ I: Integer;
286+begin
287+ for I := 0 to High(CKeys) do
288+ if CKeys[I].KeyCode = KeyCode then
289+ begin
290+ Result := @CKeys[I];
291+ Exit;
292+ end;
293+ Result := nil;
294+end;
295+
296+// This has a complexity of 11, because of the if else ladder.
297+// That bugs me a bit. Looking for something more elegant.
298+function TranslateKey(const Rec: TInputRecord; State: Integer; Key: PKey; KeyCode: Integer): Smallint;
299+begin
300+ if State and (RIGHT_ALT_PRESSED or LEFT_ALT_PRESSED) <> 0 then
301+ Result := Key^.Alt
302+ else if State and (RIGHT_CTRL_PRESSED or LEFT_CTRL_PRESSED) <> 0 then
303+ Result := Key^.Ctrl
304+ else if State and SHIFT_PRESSED <> 0 then
305+ Result := Key^.Shift
306+ else if KeyCode in [Ord('A')..Ord('Z')] then
307+ Result := Ord(Rec.Event.KeyEvent.AsciiChar)
308+ else
309+ Result := Key^.Normal;
310+end;
311+
312+function ConvertKey(const Rec: TInputRecord; Key: PKey): Smallint;
313+ {$IFDEF INLINES}inline;{$ENDIF}
314+begin
315+ if Assigned(Key) then
316+ Result := TranslateKey(Rec, Rec.Event.KeyEvent.dwControlKeyState,
317+ Key, Rec.Event.KeyEvent.wVirtualKeyCode)
318+ else
319+ Result := -1
320+end;
321+
322+function ReadKey: Char;
323+var
324+ InputRec: TInputRecord;
325+ NumRead: Cardinal;
326+ KeyMode: DWORD;
327+ KeyCode: Smallint;
328+begin
329+ if ExtendedChar <> #0 then
330+ begin
331+ Result := ExtendedChar;
332+ ExtendedChar := #0;
333+ Exit;
334+ end
335+ else
336+ begin
337+ Result := #$FF;
338+ GetConsoleMode(StdIn, KeyMode);
339+ SetConsoleMode(StdIn, 0);
340+ repeat
341+ ReadConsoleInput(StdIn, InputRec, 1, NumRead);
342+ if (InputRec.EventType and KEY_EVENT <> 0) and
343+ InputRec.Event.KeyEvent.bKeyDown then
344+ begin
345+ if InputRec.Event.KeyEvent.AsciiChar <> #0 then
346+ begin
347+ // From Delphi 2009 on, Result is WideChar
348+ Result := Chr(Ord(InputRec.Event.KeyEvent.AsciiChar));
349+ Break;
350+ end;
351+ KeyCode := ConvertKey(InputRec,
352+ FindKeyCode(InputRec.Event.KeyEvent.wVirtualKeyCode));
353+ if KeyCode > $FF then
354+ begin
355+ ExtendedChar := Chr(KeyCode and $FF);
356+ Result := #0;
357+ Break;
358+ end;
359+ end;
360+ until False;
361+ SetConsoleMode(StdIn, KeyMode);
362+ end;
363+end;
364+
365+function KeyPressed: Boolean;
366+var
367+ InputRecArray: array of TInputRecord;
368+ NumRead: DWORD;
369+ NumEvents: DWORD;
370+ I: Integer;
371+ KeyCode: Word;
372+begin
373+ Result := False;
374+ GetNumberOfConsoleInputEvents(StdIn, NumEvents);
375+ if NumEvents = 0 then
376+ Exit;
377+ SetLength(InputRecArray, NumEvents);
378+ PeekConsoleInput(StdIn, InputRecArray[0], NumEvents, NumRead);
379+ for I := 0 to High(InputRecArray) do
380+ begin
381+ if (InputRecArray[I].EventType and Key_Event <> 0) and
382+ InputRecArray[I].Event.KeyEvent.bKeyDown then
383+ begin
384+ KeyCode := InputRecArray[I].Event.KeyEvent.wVirtualKeyCode;
385+ if not (KeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL]) then
386+ begin
387+ if ConvertKey(InputRecArray[I], FindKeyCode(KeyCode)) <> -1 then
388+ begin
389+ Result := True;
390+ Exit;
391+ end;
392+ end;
393+ end;
394+ end;
395+end;
396+
397+procedure TextColor(Color: Byte);
398+begin
399+ LastMode := TextAttr;
400+ TextAttr := (TextAttr and $F0) or (Color and $0F);
401+ SetConsoleTextAttribute(StdOut, TextAttr);
402+end;
403+
404+procedure TextBackground(Color: Byte);
405+begin
406+ LastMode := TextAttr;
407+ TextAttr := (TextAttr and $0F) or ((Color shl 4) and $F0);
408+ SetConsoleTextAttribute(StdOut, TextAttr);
409+end;
410+
411+procedure LowVideo;
412+begin
413+ LastMode := TextAttr;
414+ TextAttr := TextAttr and $F7;
415+ SetConsoleTextAttribute(StdOut, TextAttr);
416+end;
417+
418+procedure HighVideo;
419+begin
420+ LastMode := TextAttr;
421+ TextAttr := TextAttr or $08;
422+ SetConsoleTextAttribute(StdOut, TextAttr);
423+end;
424+
425+procedure NormVideo;
426+begin
427+ TextAttr := DefaultAttr;
428+ SetConsoleTextAttribute(StdOut, TextAttr);
429+end;
430+
431+// The following functions are independent of TextWindow.
432+
433+function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
434+var
435+ BufferInfo: TConsoleScreenBufferInfo;
436+begin
437+ GetConsoleSCreenBufferInfo(StdOut, BufferInfo);
438+ Result := BufferInfo.dwCursorPosition.X;
439+end;
440+
441+function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
442+var
443+ BufferInfo: TConsoleScreenBufferInfo;
444+begin
445+ GetConsoleSCreenBufferInfo(StdOut, BufferInfo);
446+ Result := BufferInfo.dwCursorPosition.Y;
447+end;
448+
449+procedure SetCursorPos(X, Y: Smallint);
450+var
451+ NewPos: TCoord;
452+begin
453+ NewPos.X := X;
454+ NewPos.Y := Y;
455+ SetConsoleCursorPosition(StdOut, NewPos);
456+end;
457+
458+// The following functions are relative to TextWindow.
459+
460+procedure ClrScr;
461+var
462+ StartPos: TCoord;
463+ Len, NumWritten: DWORD;
464+ I: Integer;
465+begin
466+ if (TextWindow.Left = 0) and (TextWindow.Top = 0) and
467+ (TextWindow.Right = BufferSize.X - 1) and
468+ (TextWindow.Bottom = BufferSize.Y - 1) then
469+ begin
470+ StartPos.X := 0;
471+ StartPos.Y := 0;
472+ Len := BufferSize.X * BufferSize.Y;
473+ FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten);
474+ FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten);
475+ if NumWritten < Len then
476+ begin
477+ ScreenSize.X := ScreenWidth;
478+ ScreenSize.Y := ScreenHeight;
479+ end;
480+ end
481+ else
482+ begin
483+ Len := TextWindow.Right - TextWindow.Left + 1;
484+ StartPos.X := TextWindow.Left;
485+ for I := TextWindow.Top to TextWindow.Bottom do
486+ begin
487+ StartPos.Y := I;
488+ FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten);
489+ FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten);
490+ end;
491+ end;
492+ GotoXY(1, 1);
493+end;
494+
495+procedure GotoXY(X, Y: Smallint);
496+begin
497+ Inc(X, TextWindow.Left - 1);
498+ Inc(Y, TextWindow.Top - 1);
499+ if (X >= TextWindow.Left) and (X <= TextWindow.Right) and
500+ (Y >= TextWindow.Top) and (Y <= TextWindow.Bottom) then
501+ SetCursorPos(X, Y);
502+end;
503+
504+procedure ClrEol;
505+var
506+ Len: Integer;
507+ Pos: TCoord;
508+ NumWritten: DWORD;
509+begin
510+ Len := TextWindow.Right - GetCursorX + 1;
511+ Pos.X := GetCursorX;
512+ Pos.Y := GetCursorY;
513+ FillConsoleOutputCharacterA(StdOut, ' ', Len, Pos, NumWritten);
514+ FillConsoleOutputAttribute(StdOut, TextAttr, Len, Pos, NumWritten);
515+end;
516+
517+procedure Scroll(Left, Top, Right, Bottom: Integer; Distance: Integer = 0);
518+var
519+ Rect: TSmallRect;
520+ Fill: TCharInfo;
521+ NewPos: TCoord;
522+begin
523+ Fill.AsciiChar := ' ';
524+ Fill.Attributes := TextAttr;
525+ if Distance = 0 then
526+ Distance := Bottom - Top + 1;
527+ Rect.Left := Left;
528+ Rect.Right := Right;
529+ Rect.Top := Top;
530+ Rect.Bottom := Bottom;
531+ NewPos.X := Left;
532+ NewPos.Y := Top + Distance;
533+ ScrollConsoleScreenBufferA(StdOut, Rect, @Rect, NewPos, Fill);
534+end;
535+
536+procedure InsLine;
537+begin
538+ Scroll(TextWindow.Left, GetCursorY,
539+ TextWindow.Right, TextWindow.Bottom, 1);
540+end;
541+
542+procedure DelLine;
543+begin
544+ Scroll(TextWindow.Left, GetCursorY,
545+ TextWindow.Right, TextWindow.Bottom, -1);
546+end;
547+
548+function Validate(X1, Y1, X2, Y2: Integer): Boolean;
549+ {$IFDEF INLINES}inline;{$ENDIF}
550+begin
551+ Result := (X1 < X2) and (Y1 < Y2) and
552+ (X1 >= 0) and (X2 < BufferSize.X) and
553+ (Y1 >= 0) and (Y2 < BufferSize.Y);
554+end;
555+
556+procedure WriteText(Line: PAnsiChar; Len: Integer);
557+var
558+ NumWritten: DWORD;
559+begin
560+ SetConsoleTextAttribute(StdOut, TextAttr);
561+ WriteConsoleA(StdOut, Line, Len, NumWritten, nil);
562+end;
563+
564+// Replacement for TTextRec.InOutFunc and TTextRec.FlushFunc for the Output
565+// and ErrOutput pseudo-textfiles.
566+// This is generally only used if a text window is set, otherwise this is
567+// handled by the runtime library.
568+function NewTextOut(var T: TTextRec): Integer;
569+var
570+ ReadPtr, WritePtr: PAnsiChar;
571+ Line: AnsiString;
572+ DistanceToEdge: Integer;
573+
574+ // Moves cursor to start of line, updates DistanceToEdge.
575+ procedure CarriageReturn;
576+ begin
577+ SetCursorPos(TextWindow.Left, GetCursorY);
578+ DistanceToEdge := TextWindow.Right - TextWindow.Left + 1;
579+ end;
580+
581+ // Moves cursor down one line. If necessary, scrolls window.
582+ procedure LineFeed; {$IFDEF INLINES}inline;{$ENDIF}
583+ begin
584+ if GetCursorY < TextWindow.Bottom then
585+ SetCursorPos(GetCursorX, GetCursorY + 1)
586+ else
587+ Scroll(TextWindow.Left, TextWindow.Top, TextWindow.Right,
588+ TextWindow.Bottom, -1);
589+ end;
590+
591+ // Store one char in write buffer.
592+ procedure CharToWriteBuffer(C: AnsiChar);
593+ begin
594+ WritePtr^ := C;
595+ Inc(WritePtr);
596+ Dec(DistanceToEdge);
597+ end;
598+
599+ // True if at right edge of window.
600+ function WriteLine: Boolean;
601+ begin
602+ WritePtr^ := #0;
603+ WriteText(PAnsiChar(Line), WritePtr - PAnsiChar(Line));
604+ Result := DistanceToEdge = 0;
605+ WritePtr := PAnsiChar(Line);
606+ DistanceToEdge := TextWindow.Right - TextWindow.Left + 1;
607+ end;
608+
609+ // Converts tabs to spaces, since WriteConsole will do its own tabbing when
610+ // it encounters a #9, which is of course independent of this unit's
611+ // TextWindow settings.
612+ procedure ProcessTab;
613+ var
614+ Num, I: Integer;
615+ begin
616+ Num := 8 - (WritePtr - PAnsiChar(Line)) mod 8;
617+ if Num > DistanceToEdge then
618+ Num := DistanceToEdge;
619+ for I := 1 to Num do
620+ CharToWriteBuffer(' ');
621+ end;
622+
623+begin
624+ SetLength(Line, BufferSize.X); // Line only contains one line of windowed text.
625+ WritePtr := PAnsiChar(Line);
626+ ReadPtr := T.BufPtr;
627+ DistanceToEdge := TextWindow.Right - GetCursorX + 1;
628+ while T.BufPos > 0 do
629+ begin
630+ while (T.BufPos > 0) and (DistanceToEdge > 0) do
631+ begin
632+ case ReadPtr^ of
633+ #7: Windows.Beep(800, 200); // this is what my internal speaker uses.
634+ #8: begin
635+ Dec(WritePtr);
636+ Inc(DistanceToEdge);
637+ end;
638+ #9: ProcessTab;
639+ // LineFeed is not just a line feed, it takes the function of #13#10
640+ #10: begin
641+ WriteLine;
642+ CarriageReturn;
643+ LineFeed;
644+ end;
645+ #13: begin
646+ WriteLine;
647+ CarriageReturn;
648+ end;
649+ else
650+ CharToWriteBuffer(ReadPtr^);
651+ end;
652+ Inc(ReadPtr);
653+ Dec(T.BufPos);
654+ end;
655+ if WriteLine then
656+ begin
657+ CarriageReturn;
658+ // If TexWindow.Right is at the edge of the screen, WriteConsole will
659+ // already do a linefeed.
660+ if TextWindow.Right <> ScreenWidth - 1 then
661+ LineFeed;
662+ end;
663+ end;
664+ Result := 0;
665+end;
666+
667+var
668+ OldInOutFunc: Pointer;
669+ OldFlushFunc: Pointer;
670+
671+procedure Window(Left, Top, Right, Bottom: Integer);
672+begin
673+ Dec(Left);
674+ Dec(Top);
675+ Dec(Right);
676+ Dec(Bottom);
677+ if Validate(Left, Top, Right, Bottom) then
678+ begin
679+ TextWindow.Left := Left;
680+ TextWindow.Top := Top;
681+ TextWindow.Right := Right;
682+ TextWindow.Bottom := Bottom;
683+ if (Left > 0) or (Top > 0) or
684+ (Right < BufferSize.X - 1) or (Bottom < BufferSize.Y - 1) then
685+ // Text must be contained in window
686+ begin
687+ OldInOutFunc := TTextRec(Output).InOutFunc;
688+ OldFlushFunc := TTextRec(Output).FlushFunc;
689+ TTextRec(Output).InOutFunc := @NewTextOut;
690+ TTextRec(Output).FlushFunc := @NewTextOut;
691+ SetCursorPos(Left, Top);
692+ end;
693+ end
694+ else
695+ begin
696+ TextWindow.Left := 0;
697+ TextWindow.Right := BufferSize.X - 1;
698+ TextWindow.Top := 0;
699+ TextWindow.Bottom := BufferSize.Y - 1;
700+ SetCursorPos(0, 0);
701+ if Assigned(OldInOutFunc) then
702+ begin
703+ TTextRec(Output).InOutFunc := OldInOutFunc;
704+ OldInOutFunc := nil;
705+ end;
706+ if Assigned(OldFlushFunc) then
707+ begin
708+ TTextRec(Output).FlushFunc := OldFlushFunc;
709+ OldFlushFunc := nil;
710+ end;
711+ end;
712+ WindMin := (TextWindow.Left and $FF) or (TextWindow.Top and $FF) shl 8;
713+ WindMax := (TextWindow.Right and $FF) or (TextWindow.Bottom and $FF) shl 8;
714+end;
715+
716+procedure HardwareSound(Frequency: Smallint);
717+asm
718+ CMP AX,37
719+ JB @@1
720+ MOV CX,AX
721+ MOV AL,$B6
722+ OUT $43,AL
723+ MOV AX,$3540
724+ MOV DX,$0012
725+ DIV CX
726+ OUT $42,AL
727+ MOV AL,AH
728+ OUT $42,AL
729+ MOV AL,3
730+ OUT $61,AL
731+@@1:
732+end;
733+
734+procedure HardwareNoSound;
735+asm
736+ MOV AL,0
737+ OUT $61,AL
738+end;
739+
740+procedure HardwareDelay(Millisecs: Integer);
741+begin
742+ Sleep(Millisecs);
743+end;
744+
745+procedure HardwareBeep(Frequency, Duration: Smallint);
746+begin
747+ Sound(Frequency);
748+ Delay(Duration);
749+ NoSound;
750+end;
751+
752+type
753+ TSoundState = (ssPending, ssPlaying, ssFreed);
754+
755+var
756+ CurrentFrequency: Integer;
757+ SoundState: TSoundState;
758+
759+// On Windows NT and later, direct port access is prohibited, so there is
760+// no way to use HardwareSound and HardwareNoSound.
761+//
762+// Since probably every note played by Sound will be delimited by some kind
763+// of Delay, the playing of the note is deferred to Delay. Sound only stores
764+// the frequency and sets the SoundState to ssPending. Delay now knows both
765+// parameters, and can use Windows.Beep.
766+//
767+// Note that such code is not reentrant.
768+
769+procedure SoftwareSound(Frequency: Smallint);
770+begin
771+ // $123540 div Frequency must be <= $7FFF, so Frequency must be >= 37.
772+ if Frequency >= 37 then
773+ begin
774+ CurrentFrequency := Frequency;
775+ SoundState := ssPending;
776+ end;
777+end;
778+
779+procedure SoftwareDelay(Millisecs: Integer);
780+begin
781+ if SoundState = ssPending then
782+ begin
783+ SoundState := ssPlaying;
784+ Windows.Beep(CurrentFrequency, MilliSecs);
785+ SoundState := ssFreed;
786+ end
787+ else
788+ Sleep(MilliSecs);
789+end;
790+
791+procedure SoftwareBeep(Frequency, Duration: Smallint);
792+begin
793+ if Frequency >= 37 then
794+ begin
795+ SoundState := ssPlaying;
796+ Windows.Beep(Frequency, Duration);
797+ SoundState := ssFreed;
798+ end;
799+end;
800+
801+procedure SoftwareNoSound;
802+begin
803+ Windows.Beep(CurrentFrequency, 0);
804+ SoundState := ssFreed;
805+end;
806+
807+function WhereX: Integer;
808+begin
809+ Result := GetCursorX - TextWindow.Left + 1;
810+end;
811+
812+function WhereY: Integer;
813+begin
814+ Result := GetCursorY - TextWindow.Top + 1;
815+end;
816+
817+procedure GetScreenSizes(var Width, Height: Smallint);
818+var
819+ BufferInfo: TConsoleScreenBufferInfo;
820+begin
821+ GetConsoleScreenBufferInfo(StdOut, BufferInfo);
822+ Width := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1;
823+ Height := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1;
824+end;
825+
826+function ScreenWidth: Smallint;
827+var
828+ Height: Smallint;
829+begin
830+ GetScreenSizes(Result, Height);
831+end;
832+
833+function ScreenHeight: Smallint;
834+var
835+ Width: Smallint;
836+begin
837+ GetScreenSizes(Width, Result);
838+end;
839+
840+procedure GetBufferSizes(var Width, Height: Smallint);
841+var
842+ BufferInfo: TConsoleScreenBufferInfo;
843+begin
844+ GetConsoleScreenBufferInfo(StdOut, BufferInfo);
845+ Width := BufferInfo.dwSize.X;
846+ Height := BufferInfo.dwSize.Y;
847+end;
848+
849+function BufferWidth: Smallint;
850+var
851+ Height: Smallint;
852+begin
853+ GetBufferSizes(Result, Height);
854+end;
855+
856+function BufferHeight: Smallint;
857+var
858+ Width: Smallint;
859+begin
860+ GetBufferSizes(Width, Result);
861+end;
862+
863+function TextColor: Byte;
864+begin
865+ Result := TextAttr and $0F;
866+end;
867+
868+function TextBackground: Byte;
869+begin
870+ Result := (TextAttr and $F0) shr 4;
871+end;
872+
873+procedure TextMode(Mode: Word);
874+begin
875+ Window(0, 0, 0, 0);
876+ NormVideo;
877+end;
878+
879+function Pause(const Msg: string = ''): Char;
880+begin
881+ if Msg = '' then
882+ Write('Press any key... ')
883+ else
884+ Write(Msg);
885+ Result := ReadKey;
886+end;
887+
888+procedure InitScreenMode;
889+var
890+ BufferInfo: TConsoleScreenBufferInfo;
891+begin
892+ Reset(Input);
893+ Rewrite(Output);
894+ StdIn := TTextRec(Input).Handle;
895+ StdOut := TTextRec(Output).Handle;
896+{$IFDEF HASERROUTPUT}
897+ Rewrite(ErrOutput);
898+ StdErr := TTextRec(ErrOutput).Handle;
899+{$ELSE}
900+ StdErr := GetStdHandle(STD_ERROR_HANDLE);
901+{$ENDIF}
902+ if not GetConsoleScreenBufferInfo(StdOut, BufferInfo) then
903+ begin
904+ SetInOutRes(GetLastError);
905+ Exit;
906+ end;
907+ TextWindow.Left := 0;
908+ TextWindow.Top := 0;
909+ TextWindow.Right := BufferInfo.dwSize.X - 1;
910+ TextWindow.Bottom := BufferInfo.dwSize.Y - 1;
911+ TextAttr := BufferInfo.wAttributes and $FF;
912+ DefaultAttr := TextAttr;
913+ BufferSize := BufferInfo.dwSize;
914+ ScreenSize.X := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1;
915+ ScreenSize.Y := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1;
916+ WindMin := 0;
917+ WindMax := (ScreenSize.X and $FF) or (ScreenSize.Y and $FF) shl 8;
918+ LastMode := CO80;
919+ OldInOutFunc := nil;
920+ OldFlushFunc := nil;
921+ if Win32Platform = VER_PLATFORM_WIN32_NT then
922+ begin
923+ Sound := SoftwareSound;
924+ NoSound := SoftwareNoSound;
925+ Delay := SoftwareDelay;
926+ Beep := SoftwareBeep;
927+ end
928+ else
929+ begin
930+ Sound := HardwareSound;
931+ NoSound := HardwareNoSound;
932+ Delay := HardwareDelay;
933+ Beep := HardwareBeep;
934+ end;
935+end;
936+
937+initialization
938+ InitScreenMode;
939+
940+end.
941+
--- tags/1.0.8/src/dzBdsLauncher.dpr (nonexistent)
+++ tags/1.0.8/src/dzBdsLauncher.dpr (revision 48)
@@ -0,0 +1,17 @@
1+program dzBdsLauncher;
2+
3+{$APPTYPE CONSOLE}
4+
5+uses
6+ System.SysUtils,
7+ u_dzBdsLauncher in 'u_dzBdsLauncher.pas',
8+ Velthuis.Console in 'Velthuis.Console.pas',
9+ u_dzStdOut in 'u_dzStdOut.pas';
10+
11+{$R *_version.res}
12+{$R *_icon.res}
13+{$R *_manifest.res}
14+
15+begin
16+ Main;
17+end.
--- tags/1.0.8/src/dzBdsLauncher.dproj (nonexistent)
+++ tags/1.0.8/src/dzBdsLauncher.dproj (revision 48)
@@ -0,0 +1,139 @@
1+<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
2+ <PropertyGroup>
3+ <Base>True</Base>
4+ <AppType>Console</AppType>
5+ <Config Condition="'$(Config)'==''">Debug</Config>
6+ <FrameworkType>None</FrameworkType>
7+ <MainSource>dzBdsLauncher.dpr</MainSource>
8+ <Platform Condition="'$(Platform)'==''">Win32</Platform>
9+ <ProjectGuid>{4CA0A90D-F239-46ED-A855-D1C0E0DEDAC1}</ProjectGuid>
10+ <ProjectVersion>19.1</ProjectVersion>
11+ <TargetedPlatforms>1</TargetedPlatforms>
12+ </PropertyGroup>
13+ <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
14+ <Base>true</Base>
15+ </PropertyGroup>
16+ <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
17+ <Base_Win32>true</Base_Win32>
18+ <CfgParent>Base</CfgParent>
19+ <Base>true</Base>
20+ </PropertyGroup>
21+ <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''">
22+ <Cfg_1>true</Cfg_1>
23+ <CfgParent>Base</CfgParent>
24+ <Base>true</Base>
25+ </PropertyGroup>
26+ <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
27+ <Cfg_1_Win32>true</Cfg_1_Win32>
28+ <CfgParent>Cfg_1</CfgParent>
29+ <Cfg_1>true</Cfg_1>
30+ <Base>true</Base>
31+ </PropertyGroup>
32+ <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
33+ <Cfg_2>true</Cfg_2>
34+ <CfgParent>Base</CfgParent>
35+ <Base>true</Base>
36+ </PropertyGroup>
37+ <PropertyGroup Condition="'$(Base)'!=''">
38+ <SanitizedProjectName>dzBdsLauncher</SanitizedProjectName>
39+ <DCC_DUPLICATE_CTOR_DTOR>false</DCC_DUPLICATE_CTOR_DTOR>
40+ <DCC_DcuOutput>..\dcu\$(Platform)\$(Config)</DCC_DcuOutput>
41+ <DCC_Define>NO_TRANSLATION;NO_TRANSLATION_HINT;$(DCC_Define)</DCC_Define>
42+ <DCC_ExeOutput>..\</DCC_ExeOutput>
43+ <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace>
44+ <DCC_SYMBOL_PLATFORM>false</DCC_SYMBOL_PLATFORM>
45+ <DCC_UNIT_PLATFORM>false</DCC_UNIT_PLATFORM>
46+ <DCC_UnitSearchPath>..\libs\dzlib\src;..\libs\dzlib\jedi_inc;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
47+ <PostBuildEvent>
48+ <![CDATA[call ..\buildtools\postbuild.cmd $(OUTPUTDIR)$(OUTPUTNAME)
49+$(PostBuildEvent)]]>
50+ </PostBuildEvent>
51+ <PreBuildEvent>
52+ <![CDATA[call ..\buildtools\prebuild.cmd $(PROJECTPATH)
53+$(PreBuildEvent)]]>
54+ </PreBuildEvent>
55+ <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
56+ <VerInfo_Locale>2057</VerInfo_Locale>
57+ </PropertyGroup>
58+ <PropertyGroup Condition="'$(Base_Win32)'!=''">
59+ <BT_BuildType>Debug</BT_BuildType>
60+ <DCC_ConsoleTarget>true</DCC_ConsoleTarget>
61+ <DCC_MapFile>3</DCC_MapFile>
62+ <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
63+ <DCC_UsePackage>DBXSqliteDriver;bindcompdbx;IndyIPCommon;RESTComponents;DBXInterBaseDriver;vcl;IndyIPServer;vclactnband;ccpack;vclFireDAC;IndySystem;tethering;svnui;dsnapcon;FireDACADSDriver;VirtualTreesR;FireDACMSAccDriver;fmxFireDAC;vclimg;FireDAC;vcltouch;vcldb;bindcompfmx;svn;FireDACSqliteDriver;FireDACPgDriver;inetdb;soaprtl;DbxCommonDriver;FireDACIBDriver;fmx;fmxdae;xmlrtl;soapmidas;fmxobj;vclwinx;rtl;DbxClientDriver;CustomIPTransport;vcldsnap;dbexpress;IndyCore;vclx;bindcomp;appanalytics;dsnap;FireDACCommon;IndyIPClient;bindcompvcl;RESTBackendComponents;VCLRESTComponents;soapserver;dbxcds;VclSmp;adortl;vclie;bindengine;DBXMySQLDriver;CloudService;dsnapxml;FireDACMySQLDriver;dbrtl;inetdbxpress;IndyProtocols;FireDACCommonODBC;FireDACCommonDriver;AutoSuffix;inet;fmxase;$(DCC_UsePackage)</DCC_UsePackage>
64+ <Manifest_File>(None)</Manifest_File>
65+ <VerInfo_Locale>1033</VerInfo_Locale>
66+ </PropertyGroup>
67+ <PropertyGroup Condition="'$(Cfg_1)'!=''">
68+ <DCC_DebugDCUs>true</DCC_DebugDCUs>
69+ <DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
70+ <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
71+ <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
72+ <DCC_Optimize>false</DCC_Optimize>
73+ <DCC_RemoteDebug>true</DCC_RemoteDebug>
74+ </PropertyGroup>
75+ <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
76+ <DCC_RemoteDebug>false</DCC_RemoteDebug>
77+ </PropertyGroup>
78+ <PropertyGroup Condition="'$(Cfg_2)'!=''">
79+ <DCC_DebugInformation>0</DCC_DebugInformation>
80+ <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
81+ <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
82+ <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
83+ </PropertyGroup>
84+ <ItemGroup>
85+ <DelphiCompile Include="$(MainSource)">
86+ <MainSource>MainSource</MainSource>
87+ </DelphiCompile>
88+ <DCCReference Include="u_dzBdsLauncher.pas"/>
89+ <DCCReference Include="Velthuis.Console.pas"/>
90+ <DCCReference Include="u_dzStdOut.pas"/>
91+ <BuildConfiguration Include="Base">
92+ <Key>Base</Key>
93+ </BuildConfiguration>
94+ <BuildConfiguration Include="Debug">
95+ <Key>Cfg_1</Key>
96+ <CfgParent>Base</CfgParent>
97+ </BuildConfiguration>
98+ <BuildConfiguration Include="Release">
99+ <Key>Cfg_2</Key>
100+ <CfgParent>Base</CfgParent>
101+ </BuildConfiguration>
102+ </ItemGroup>
103+ <ProjectExtensions>
104+ <Borland.Personality>Delphi.Personality.12</Borland.Personality>
105+ <Borland.ProjectType>Application</Borland.ProjectType>
106+ <BorlandProject>
107+ <Delphi.Personality>
108+ <Source>
109+ <Source Name="MainSource">dzBdsLauncher.dpr</Source>
110+ </Source>
111+ <Excluded_Packages/>
112+ </Delphi.Personality>
113+ <Platforms>
114+ <Platform value="Win32">True</Platform>
115+ <Platform value="Win64">False</Platform>
116+ </Platforms>
117+ </BorlandProject>
118+ <ProjectFileVersion>12</ProjectFileVersion>
119+ </ProjectExtensions>
120+ <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
121+ <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/>
122+ <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/>
123+ <PropertyGroup Condition="'$(Config)'=='Debug' And '$(Platform)'=='Win32'">
124+ <PreBuildEvent>call ..\buildtools\prebuild.cmd $(PROJECTPATH)</PreBuildEvent>
125+ <PreBuildEventIgnoreExitCode>False</PreBuildEventIgnoreExitCode>
126+ <PreLinkEvent/>
127+ <PreLinkEventIgnoreExitCode>False</PreLinkEventIgnoreExitCode>
128+ <PostBuildEvent>call ..\buildtools\postbuild.cmd $(OUTPUTDIR)$(OUTPUTNAME)</PostBuildEvent>
129+ <PostBuildEventIgnoreExitCode>False</PostBuildEventIgnoreExitCode>
130+ </PropertyGroup>
131+ <PropertyGroup Condition="'$(Config)'=='Release' And '$(Platform)'=='Win32'">
132+ <PreBuildEvent>call ..\buildtools\prebuild.cmd $(PROJECTPATH)</PreBuildEvent>
133+ <PreBuildEventIgnoreExitCode>False</PreBuildEventIgnoreExitCode>
134+ <PreLinkEvent/>
135+ <PreLinkEventIgnoreExitCode>False</PreLinkEventIgnoreExitCode>
136+ <PostBuildEvent>call ..\buildtools\postbuild.cmd $(OUTPUTDIR)$(OUTPUTNAME)</PostBuildEvent>
137+ <PostBuildEventIgnoreExitCode>False</PostBuildEventIgnoreExitCode>
138+ </PropertyGroup>
139+</Project>
--- tags/1.0.8/src/dzBdsLauncher.manifest.in (nonexistent)
+++ tags/1.0.8/src/dzBdsLauncher.manifest.in (revision 48)
@@ -0,0 +1,53 @@
1+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
2+<!--
3+ This manifest tells Windows Vista to Windows 10 not to virtualize any file
4+ or registry access. Also, it disables themes support.
5+ -->
6+ <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
7+ <assemblyIdentity version="1.0.0.0"
8+ processorArchitecture="*"
9+ name="template from dzlib build tools"
10+ type="win32"/>
11+<!-- We do not want themes support
12+ <dependency>
13+ <dependentassembly>
14+ <assemblyidentity type="win32"
15+ name="Microsoft.Windows.Common-Controls"
16+ version="6.0.0.0"
17+ publickeytoken="6595b64144ccf1df"
18+ language="*" processorarchitecture="*">
19+ </assemblyidentity>
20+ </dependentassembly>
21+ <dependency>
22+ -->
23+ <description>This application was built using buildtools from dzlib</description>
24+ <!-- COMPATIBILITY SECTION SPECIFIES IF APP IS COMPLIANT
25+ DISABLES PCA IF SPECIFIED -->
26+ <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1">
27+ <application>
28+ <!-- We support Windows Vista -->
29+ <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}"/>
30+ <!-- We support Windows 7 -->
31+ <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}"/>
32+ <!-- We support Windows 8 -->
33+ <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}"/>
34+ <!-- We support Windows 8.1 -->
35+ <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}"/>
36+ <!-- We support Windows 10 -->
37+ <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}"/>
38+ </application>
39+ </compatibility>
40+
41+ <!-- TRUSTINFO SECTION SPECIFIES REQUESTED PERMISSIONS AND
42+ UIPI DISABLEMENT (SPECIAL CONDITIONS APPLY TO UIPI DISABLEMENT)-->
43+ <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
44+ <security>
45+ <requestedPrivileges>
46+ <requestedExecutionLevel
47+ level="asInvoker"
48+ uiAccess="false"
49+ />
50+ </requestedPrivileges>
51+ </security>
52+ </trustInfo>
53+</assembly>
\ No newline at end of file
--- tags/1.0.8/src/dzBdsLauncher_version.ini (nonexistent)
+++ tags/1.0.8/src/dzBdsLauncher_version.ini (revision 48)
@@ -0,0 +1,25 @@
1+[Version Info]
2+AutoIncBuild=0
3+Build=337
4+MajorVer=1
5+MinorVer=0
6+Release=8
7+Private=0
8+Special=0
9+Revision=
10+
11+[Version Info Keys]
12+FileVersion=1.0.8.337
13+ProductVersion={today}
14+FileDescription=dzBdsLauncher
15+OriginalFilename=dzBdsLauncher
16+Comments=
17+CompanyName=dummzeuch.de
18+InternalName=dzBdsLauncher
19+LegalCopyright=Thomas Mueller, 2019-{ThisYear}
20+LegalTrademarks=T. Mueller
21+ProductName=dzBdsLauncher
22+BuildDateTime={today}
23+PrivateBuild=
24+SpecialBuild=
25+
--- tags/1.0.8/src/u_dzBdsLauncher.pas (nonexistent)
+++ tags/1.0.8/src/u_dzBdsLauncher.pas (revision 48)
@@ -0,0 +1,558 @@
1+unit u_dzBdsLauncher;
2+
3+{$DEFINE WAIT_BEFORE_CALL}
4+
5+{$IFDEF RELEASE}
6+{$UNDEF WAIT_BEFORE_CALL}
7+{$ENDIF}
8+
9+interface
10+
11+uses
12+ Winapi.Windows,
13+ System.SysUtils,
14+ System.Classes,
15+ u_dzTranslator;
16+
17+procedure Main;
18+
19+implementation
20+
21+uses
22+ System.StrUtils,
23+ System.Generics.Collections,
24+ System.IniFiles,
25+ u_dzExecutor,
26+ u_dzClassUtils,
27+ u_dzStringUtils,
28+ u_dzFileUtils,
29+ u_dzTypes,
30+ u_dzStdOut;
31+
32+type
33+ TDelphiVersion = (
34+ dvUnknown,
35+ dv6, dv7,
36+ dv2005, dv2006,
37+ dv2007, dv2009, dv2010,
38+ dvXE, dvXE2, dvXE3, dvXE4, dvXE5, dvXE6, dvXE7, dvXE8,
39+ dv10, dv10_1, dv10_2, dv10_3, dv10_4,
40+ dv11);
41+ TDelphiVersionSet = set of TDelphiVersion;
42+
43+type
44+ TDelphiInfo = class
45+ private
46+ FName: string;
47+ FRegKey: string;
48+ FDllSuffix: string;
49+ FExtensions: TStringArray;
50+ FProjectVersions: TStringArray;
51+ public
52+ constructor Create(const _Name, _RegKey, _DllSuffix: string;
53+ const _ProjectVersions: TStringArray;
54+ const _Extensions: TStringArray);
55+ destructor Destroy; override;
56+ procedure CallIde(const _Param: string);
57+ function HasProductVersion(const _ProdVer: string): Boolean;
58+ function HasExtension(const _Ext: string): Boolean;
59+ function FileNameContainsDelphiVersion(const _fn: string): Boolean;
60+ property Name: string read FName;
61+ property RegKey: string read FRegKey;
62+ property DllSuffix: string read FDllSuffix;
63+ end;
64+
65+{ TDelphiInfo }
66+
67+constructor TDelphiInfo.Create(const _Name, _RegKey, _DllSuffix: string;
68+ const _ProjectVersions: TStringArray;
69+ const _Extensions: TStringArray);
70+begin
71+ inherited Create;
72+ FName := _Name;
73+ FRegKey := _RegKey;
74+ FDllSuffix := _DllSuffix;
75+ FProjectVersions := _ProjectVersions;
76+ FExtensions := _Extensions;
77+end;
78+
79+destructor TDelphiInfo.Destroy;
80+begin
81+ inherited;
82+end;
83+
84+function PrecedesText(const _SubText: string; _Text: string; _Pos: Integer): Boolean;
85+var
86+ SubLen: Integer;
87+begin
88+ SubLen := Length(_SubText);
89+ Result := _Pos - SubLen > 0;
90+ if Result then begin
91+ Result := SameText(_SubText, Copy(_Text, _Pos - SubLen, SubLen));
92+ end;
93+end;
94+
95+function TDelphiInfo.FileNameContainsDelphiVersion(const _fn: string): Boolean;
96+var
97+ p: Integer;
98+ len: Integer;
99+begin
100+ Result := False;
101+ p := RPosStr(FName, _fn);
102+ if p = 0 then
103+ Exit; //==>
104+
105+ if (p = 1) or PrecedesText('Delphi', _fn, p) or PrecedesText('BDS', _fn, p) or PrecedesText('RS', _fn, p)
106+ or CharInSet(_fn[p - 1], ['D', 'd', '.', '_', '\', '-']) then begin
107+ len := Length(FName);
108+ if ((p + len) > Length(_fn)) or CharInSet(_fn[p + len], ['.', '_', '\', '-']) then begin
109+ Result := True;
110+ Exit; //==>
111+ end;
112+ end;
113+
114+end;
115+
116+function TDelphiInfo.HasExtension(const _Ext: string): Boolean;
117+var
118+ Ext: string;
119+begin
120+ Assert(Leftstr(_Ext, 1) = '.');
121+ Ext := TailStr(_Ext, 2);
122+ Result := (IndexText(Ext, FExtensions) <> -1);
123+end;
124+
125+function TDelphiInfo.HasProductVersion(const _ProdVer: string): Boolean;
126+begin
127+ Result := (IndexText(_ProdVer, FProjectVersions) <> -1);
128+end;
129+
130+procedure TDelphiInfo.CallIde(const _Param: string);
131+var
132+ Exe: TExecutor;
133+ Executable: string;
134+ Idx: Integer;
135+begin
136+ if not TRegistry_TryReadString('SOFTWARE\' + FRegKey, 'App', Executable) then
137+ raise Exception.CreateFmt('Could not read value App from registry key "%s"', [FRegKey]);
138+ StdOut.WriteLn(ccLightGreen, 'Calling Delphi %s', [Name]);
139+ StdOut.WriteLn(ccLightGreen, Executable + ' ' + _Param);
140+{$IFDEF WAIT_BEFORE_CALL}
141+ StdOut.Pause;
142+{$ENDIF}
143+
144+ Exe := TExecutor.Create;
145+ try
146+ Exe.Exename := Executable;
147+ Exe.Commandline := _Param;
148+ if DebugHook <> 0 then begin
149+ // When we are running in the debugger, the following environment variables have been
150+ // set by the IDE and must be deleted in order to not confuse the IDE we want to start
151+ // (Delphi 6 and 7 are particularly prone to failing if we don't do that).
152+ Idx := Exe.Environment.IndexOfName('DELPHI');
153+ if Idx <> -1 then
154+ Exe.Environment.Delete(Idx);
155+ Idx := Exe.Environment.IndexOfName('BDS');
156+ if Idx <> -1 then
157+ Exe.Environment.Delete(Idx);
158+ end;
159+ // just in case I need to inspect the environmen variables again:
160+ // exe.Exename := 'C:\Program Files\JPSoft\TCMD17x64\tcc.exe';
161+ // exe.Commandline := '';
162+ Exe.doExecute(True);
163+ finally
164+ FreeAndNil(Exe);
165+ end;
166+end;
167+
168+type
169+ TDelphiInfoList = class(TDictionary<TDelphiVersion, TDelphiInfo>)
170+ private
171+ function CheckDllSuffix(_sl: TStringList; const _ProjVer: string;
172+ const _Possibles: TDelphiVersionSet): TDelphiVersion;
173+ function CheckDprojContent(const _fn: string): TDelphiVersion;
174+ function GetDelphiVersionForDproj(const _fn: string): TDelphiVersion;
175+ procedure HandleDproj(const _fn: string);
176+ procedure HandleGroupProj(const _fn: string);
177+ procedure HandleBdsProj(const _fn: string);
178+ procedure HandleDof(const _fn: string);
179+ procedure HandleDprOrDpk(const _fn: string);
180+ function CheckExcludedPackages(_sl: TStringList; const _Possibles: TDelphiVersionSet): TDelphiVersion;
181+ public
182+ constructor Create;
183+ procedure HandleFile(const _fn: string);
184+ end;
185+
186+constructor TDelphiInfoList.Create;
187+begin
188+ inherited Create;
189+ Add(dv6, TDelphiInfo.Create('6', 'Borland\Delphi\6.0', '60', ['6.0'], ['6']));
190+ Add(dv7, TDelphiInfo.Create('7', 'Borland\Delphi\7.0', '70', ['7.0'], ['7']));
191+ Add(dv2005, TDelphiInfo.Create('2005', 'Borland\BDS\3.0', '90', [], ['2005']));
192+ Add(dv2006, TDelphiInfo.Create('2006', 'Borland\BDS\4.0', '100', [], ['2006']));
193+ Add(dv2007, TDelphiInfo.Create('2007', 'Borland\BDS\5.0', '110', [], ['2007']));
194+ Add(dv2009, TDelphiInfo.Create('2009', 'CodeGear\BDS\6.0', '120', ['12.0'], ['2009']));
195+ Add(dv2010, TDelphiInfo.Create('2010', 'CodeGear\BDS\7.0', '140', ['12.0'], ['2010']));
196+ Add(dvXE, TDelphiInfo.Create('XE', 'Embarcadero\BDS\8.0', '150', ['12.2', '12.3'], ['XE', 'XE1']));
197+ Add(dvXE2, TDelphiInfo.Create('XE2', 'Embarcadero\BDS\9.0', '160', ['13.4'], ['XE2']));
198+ Add(dvXE3, TDelphiInfo.Create('XE3', 'Embarcadero\BDS\10.0', '170', ['14.3', '14.4'], ['XE3']));
199+ Add(dvXE4, TDelphiInfo.Create('XE4', 'Embarcadero\BDS\11.0', '180', ['14.4', '14.6'], ['XE4']));
200+ Add(dvXE5, TDelphiInfo.Create('XE5', 'Embarcadero\BDS\12.0', '190', ['15.1', '15.3'], ['XE5']));
201+ Add(dvXE6, TDelphiInfo.Create('XE6', 'Embarcadero\BDS\14.0', '200', ['15.4'], ['XE6']));
202+ Add(dvXE7, TDelphiInfo.Create('XE7', 'Embarcadero\BDS\15.0', '210', ['16.0', '16.1'], ['XE7']));
203+ Add(dvXE8, TDelphiInfo.Create('XE8', 'Embarcadero\BDS\16.0', '220', ['17.2'], ['XE8']));
204+ Add(dv10, TDelphiInfo.Create('10', 'Embarcadero\BDS\17.0', '230', ['18.0', '18.1'], ['10', '10-0', '10.0', '10_0']));
205+ Add(dv10_1, TDelphiInfo.Create('10.1', 'Embarcadero\BDS\18.0', '240', ['18.1', '18.2'], ['10-1', '10.1', '10_1']));
206+ Add(dv10_2, TDelphiInfo.Create('10.2', 'Embarcadero\BDS\19.0', '250', ['18.2', '18.3', '18.4'], ['10-2', '10.2', '10_2']));
207+ Add(dv10_3, TDelphiInfo.Create('10.3', 'Embarcadero\BDS\20.0', '260', ['18.5', '18.6', '18.7', '18.8'], ['10-3', '10.3', '10_3']));
208+ Add(dv10_4, TDelphiInfo.Create('10.4', 'Embarcadero\BDS\21.0', '270', ['19.0', '19.1', '19.2'], ['10-4', '10.4', '10_4']));
209+ Add(dv11, TDelphiInfo.Create('11', 'Embarcadero\BDS\22.0', '280', ['19.3'], ['11']));
210+end;
211+
212+function TDelphiInfoList.CheckDllSuffix(_sl: TStringList; const _ProjVer: string;
213+ const _Possibles: TDelphiVersionSet): TDelphiVersion;
214+const
215+ START_TAG = '<DllSuffix>';
216+ END_TAG = '</DllSuffix>';
217+var
218+ i: Integer;
219+ s: string;
220+ len: Integer;
221+ Item: TPair<TDelphiVersion, TDelphiInfo>;
222+ dv: TDelphiVersion;
223+begin
224+ for i := 0 to _sl.Count - 1 do begin
225+ s := Trim(_sl[i]);
226+ if StartsText(START_TAG, s) and EndsText(END_TAG, s) then begin
227+ len := Length(s);
228+ s := Copy(s, Length(START_TAG) + 1, len - Length(START_TAG) - Length(END_TAG));
229+ if s <> '' then begin
230+ StdOut.WriteLn(_('Found DllSuffix %s'), [s]);
231+ if _Possibles <> [] then begin
232+ for dv in _Possibles do begin
233+ if SameText(s, Self.Items[dv].DllSuffix) then begin
234+ StdOut.WriteLn(_('DllSuffix %s was used by Delphi %s'), [s, Self.Items[dv].Name]);
235+ Exit(dv); //==>
236+ end;
237+ end;
238+ end else begin
239+ for Item in Self do begin
240+ if SameText(s, Item.Value.DllSuffix) then begin
241+ StdOut.WriteLn(_('DllSuffix %s was used by Delphi %s'), [s, Item.Value.Name]);
242+ Exit(Item.Key); //==>
243+ end;
244+ end;
245+ end;
246+ raise Exception.CreateFmt(
247+ _('Cannot determine Delphi version for ProjectVersion "%s" and DllSuffix "%s"'),
248+ [_ProjVer, s]);
249+ end;
250+ end;
251+ end;
252+ Result := dvUnknown;
253+end;
254+
255+function TDelphiInfoList.CheckExcludedPackages(_sl: TStringList;
256+ const _Possibles: TDelphiVersionSet): TDelphiVersion;
257+const
258+ START_TAG = '<Excluded_Packages Name="';
259+ END_TAG1 = '">';
260+var
261+ i: Integer;
262+ s: string;
263+ len: Integer;
264+ dv: TDelphiVersion;
265+begin
266+ Assert(_Possibles <> []);
267+
268+ Result := dvUnknown;
269+ for i := 0 to _sl.Count - 1 do begin
270+ s := Trim(_sl[i]);
271+ if StartsText(START_TAG, s) then begin
272+ len := Pos(END_TAG1, s);
273+ if len > 0 then begin
274+ s := Copy(s, Length(START_TAG) + 1, len - Length(START_TAG) - Length(END_TAG1) + 1);
275+ end else
276+ Continue; //==^
277+
278+ for dv in _Possibles do begin
279+ if EndsText(Items[dv].DllSuffix + '.bpl', s) then begin
280+ StdOut.WriteLn(Format(_('Found an excluded package with Delphi %s suffix.'), [Items[dv].Name]));
281+ Result := dv;
282+ Exit; //==>
283+ end;
284+ end;
285+ end;
286+ end;
287+end;
288+
289+function TDelphiInfoList.CheckDprojContent(const _fn: string): TDelphiVersion;
290+const
291+ START_TAG = '<ProjectVersion>';
292+ END_TAG = '</ProjectVersion>';
293+var
294+ sl: TStringList;
295+ i: Integer;
296+ s: string;
297+ len: Integer;
298+ Item: TPair<TDelphiVersion, TDelphiInfo>;
299+ Possibles: TDelphiVersionSet;
300+begin
301+ Result := dvUnknown;
302+ sl := TStringList.Create;
303+ try
304+ sl.LoadFromFile(_fn);
305+ for i := 0 to sl.Count - 1 do begin
306+ s := Trim(sl[i]);
307+ if StartsText(START_TAG, s) and EndsText(END_TAG, s) then begin
308+ len := Length(s);
309+ s := Copy(s, Length(START_TAG) + 1, len - Length(START_TAG) - Length(END_TAG));
310+ if s <> '' then begin
311+ StdOut.WriteLn(_('Found ProjectVersion "%s"'), [s]);
312+ for Item in Self do begin
313+ if Item.Value.HasProductVersion(s) then begin
314+ if Result = dvUnknown then begin
315+ StdOut.WriteLn(_('ProjectVersion "%s" was used by Delphi %s'), [s, Item.Value.Name]);
316+ Result := Item.Key;
317+ end else begin
318+ // duplicate ProjectVersion (we assume that not more than two Delphi versions
319+ // used the same ProjectVersion, which has been the case up to Delphi 10.4)
320+ StdOut.Warning.WriteLn(_('ProjectVersion "%s" can be Delphi %s or %s, checking for DllSuffix'),
321+ [s, Self.Items[Result].Name, Item.Value.Name]);
322+ Possibles := [Result, Item.Key];
323+ Result := CheckDllSuffix(sl, s, Possibles);
324+ if Result = dvUnknown then begin
325+ StdOut.Warning.WriteLn(_('Did not find DllSuffix, checking Excluded_Packages'));
326+ Result := CheckExcludedPackages(sl, Possibles);
327+ end;
328+ Exit; //==>
329+ end;
330+ end;
331+ end;
332+ if Result <> dvUnknown then begin
333+ Exit; //==>
334+ end;
335+ StdOut.Warning.WriteLn(_('ProjectVersion "%s" unkonwn checking for DllSuffix'), [s]);
336+ Result := CheckDllSuffix(sl, s, [dv10..dv10_3]);
337+ if Result = dvUnknown then begin
338+ StdOut.Warning.WriteLn(_('Did not find DllSuffix, checking Excluded_Packages'));
339+ Result := CheckExcludedPackages(sl, Possibles);
340+ end;
341+ Exit; //==
342+ end else
343+ raise Exception.CreateFmt(_('Cannot determine Delphi version for ProjectVersion "%s"'), [s]);
344+ end;
345+ end;
346+ // no <ProjectVersion> means Delphi 2007
347+ StdOut.WriteLn(_('No ProjectVersion found, assuming Delphi 2007'));
348+ Result := dv2007;
349+ finally
350+ FreeAndNil(sl);
351+ end;
352+end;
353+
354+function TDelphiInfoList.GetDelphiVersionForDproj(const _fn: string): TDelphiVersion;
355+var
356+ fno: string;
357+ dir: string;
358+ Suffix: string;
359+ Item: TPair<TDelphiVersion, TDelphiInfo>;
360+begin
361+ dir := ExtractFileDir(_fn);
362+ fno := ChangeFileExt(ExtractFileName(_fn), '');
363+ Suffix := ExtractFileExt(fno);
364+ if Suffix <> '' then begin
365+ StdOut.WriteLn(_('Suffix is %s'), [Suffix]);
366+ for Item in Self do begin
367+ if Item.Value.HasExtension(Suffix) then
368+ Exit(Item.Key); //==>
369+ end;
370+ end;
371+ StdOut.Warning.WriteLn(_('No known suffix detected, reading DPROJ file.'));
372+ Result := CheckDprojContent(_fn);
373+end;
374+
375+procedure TDelphiInfoList.HandleDproj(const _fn: string);
376+var
377+ dv: TDelphiVersion;
378+begin
379+ dv := GetDelphiVersionForDproj(_fn);
380+ Items[dv].CallIde(_fn);
381+end;
382+
383+procedure TDelphiInfoList.HandleGroupProj(const _fn: string);
384+const
385+ START_TAG = '<Projects Include="';
386+ END_TAG1 = '">';
387+ END_TAG2 = '" />';
388+var
389+ sl: TStringList;
390+ i: Integer;
391+ s: string;
392+ len: Integer;
393+ dir: string;
394+ dv: TDelphiVersion;
395+ Item: TPair<TDelphiVersion, TDelphiInfo>;
396+begin
397+ sl := TStringList.Create;
398+ try
399+ sl.LoadFromFile(_fn);
400+ for i := 0 to sl.Count - 1 do begin
401+ s := Trim(sl[i]);
402+ if StartsText(START_TAG, s) then begin
403+ len := Length(s);
404+ if EndsText(END_TAG1, s) then begin
405+ s := Copy(s, Length(START_TAG) + 1, len - Length(START_TAG) - Length(END_TAG1));
406+ end else if EndsText(END_TAG2, s) then begin
407+ s := Copy(s, Length(START_TAG) + 1, len - Length(START_TAG) - Length(END_TAG2));
408+ end else
409+ Continue; //==^
410+
411+ dir := ExtractFileDir(_fn);
412+ s := TFileSystem.ExpandFileNameRelBaseDir(s, dir);
413+ StdOut.WriteLn(_('First project is: %s'), [s]);
414+ dv := GetDelphiVersionForDproj(s);
415+ if dv <> dvUnknown then begin
416+ Items[dv].CallIde(_fn);
417+ Exit; //==>
418+ end;
419+ end;
420+ end;
421+ StdOut.WriteLn(_('Checking project group filename'));
422+ for Item in Self do begin
423+ if Item.Value.FileNameContainsDelphiVersion(_fn) then begin
424+ Item.Value.CallIde(_fn);
425+ Exit; //==>
426+ end;
427+ end;
428+ finally
429+ FreeAndNil(sl);
430+ end;
431+ raise Exception.CreateFmt(_('Could not determine Delhpi version for %s'), [_fn]);
432+end;
433+
434+procedure TDelphiInfoList.HandleBdsProj(const _fn: string);
435+const
436+ START_TAG = '<Excluded_Packages Name="';
437+ END_TAG1 = '">';
438+ END_TAG2 = '" />';
439+var
440+ sl: TStringList;
441+ DprFn: string;
442+ dv: TDelphiVersion;
443+begin
444+ sl := TStringList.Create;
445+ try
446+ sl.LoadFromFile(_fn);
447+ dv := CheckExcludedPackages(sl, [dv2005, dv2006]);
448+ if dv <> dvUnknown then begin
449+ DprFn := ChangeFileExt(_fn, '.dpr');
450+ Items[dv].CallIde(DprFn);
451+ Exit; //==>
452+ end;
453+ finally
454+ FreeAndNil(sl);
455+ end;
456+ raise Exception.CreateFmt(_('Could not determine Delhpi version for %s'), [_fn]);
457+end;
458+
459+procedure TDelphiInfoList.HandleDof(const _fn: string);
460+var
461+ Ini: TMemIniFile;
462+ Version: string;
463+ DprFn: string;
464+begin
465+ DprFn := ChangeFileExt(_fn, '.dpr');
466+ Ini := TMemIniFile.Create(_fn);
467+ try
468+ Version := Ini.readString('FileVersion', 'Version', '');
469+ if Version = '6.0' then
470+ Items[dv6].CallIde(DprFn)
471+ else if Version = '7.0' then
472+ Items[dv7].CallIde(DprFn)
473+ else
474+ raise Exception.CreateFmt(_('Could not determine Delhpi version for %s'), [_fn]);
475+ finally
476+ FreeAndNil(Ini);
477+ end;
478+end;
479+
480+procedure TDelphiInfoList.HandleDprOrDpk(const _fn: string);
481+var
482+ fn: string;
483+begin
484+ // we can't determine the Delphi version based on the DPR file, so we look for a corresponding
485+ // DPROJ, BDSPROJ or DOF file
486+ fn := ChangeFileExt(_fn, '.dproj');
487+ if FileExists(fn) then begin
488+ HandleDproj(fn);
489+ end else begin
490+ fn := ChangeFileExt(_fn, '.bdsproj');
491+ if FileExists(fn) then begin
492+ HandleBdsProj(fn);
493+ end else begin
494+ fn := ChangeFileExt(_fn, '.dof');
495+ if FileExists(fn) then begin
496+ HandleDof(fn);
497+ end;
498+ end;
499+ end;
500+end;
501+
502+procedure TDelphiInfoList.HandleFile(const _fn: string);
503+var
504+ Ext: string;
505+begin
506+ Ext := ExtractFileExt(_fn);
507+ if SameText(Ext, '.dpr') then begin
508+ StdOut.WriteLn('DPR file detected');
509+ HandleDprOrDpk(_fn);
510+ end else if SameText(Ext, '.dpk') then begin
511+ StdOut.WriteLn('DPK file detected');
512+ HandleDprOrDpk(_fn);
513+ end else if SameText(Ext, '.dproj') then begin
514+ StdOut.WriteLn('DPROJ file detected');
515+ HandleDproj(_fn);
516+ end else if SameText(Ext, '.groupproj') then begin
517+ StdOut.WriteLn('GROUPPROJ file detected');
518+ HandleGroupProj(_fn);
519+ end else if SameText(Ext, '.bdsproj') then begin
520+ StdOut.WriteLn('BDSPROJ file detected');
521+ HandleBdsProj(_fn);
522+ end else if SameText(Ext, '.dof') then begin
523+ StdOut.WriteLn('DOF file detected');
524+ HandleDof(_fn);
525+ end else
526+ raise Exception.Create('Only .dproj or .groupproj files are supported.');
527+end;
528+
529+procedure Main;
530+var
531+ fn: string;
532+ List: TDelphiInfoList;
533+begin
534+ try
535+ StdOut.WriteLn('dzBdsLauncher was called as:');
536+ StdOut.WriteLn(ccWhite, GetCommandLine);
537+ if ParamCount <> 1 then
538+ raise Exception.Create('You must pass excatly one .dproj or .groupproj file as parameter.');
539+
540+ List := TDelphiInfoList.Create;
541+ try
542+ fn := ParamStr(1);
543+ List.HandleFile(fn);
544+ finally
545+ FreeAndNil(List);
546+ end;
547+ except
548+ on E: Exception do begin
549+ StdOut.Error.WriteLn('%s: %s', [E.ClassName, E.Message]);
550+ StdOut.Pause('Press enter');
551+ end;
552+ end;
553+end;
554+
555+end.
556+
557+
558+
--- tags/1.0.8/src/u_dzStdOut.pas (nonexistent)
+++ tags/1.0.8/src/u_dzStdOut.pas (revision 48)
@@ -0,0 +1,200 @@
1+unit u_dzStdOut;
2+
3+interface
4+
5+uses
6+ SysUtils,
7+ Velthuis.Console;
8+
9+type
10+ TConsoleColors = (
11+ // Background and foreground colors
12+ ccBlack = Velthuis.Console.Black,
13+ ccBlue = Velthuis.Console.Blue,
14+ ccGreen = Velthuis.Console.Green,
15+ ccCyan = Velthuis.Console.Cyan,
16+ ccRed = Velthuis.Console.Red,
17+ ccMagenta = Velthuis.Console.Magenta,
18+ ccBrown = Velthuis.Console.Brown,
19+ ccLightGray = Velthuis.Console.LightGray,
20+
21+ // Foreground colors
22+ ccDarkGray = Velthuis.Console.DarkGray,
23+ ccLightBlue = Velthuis.Console.LightBlue,
24+ ccLightGreen = Velthuis.Console.LightGreen,
25+ ccLightCyan = Velthuis.Console.LightCyan,
26+ ccLightRed = Velthuis.Console.LightRed,
27+ ccLightMagenta = Velthuis.Console.LightMagenta,
28+ ccYellow = Velthuis.Console.Yellow,
29+ ccWhite = Velthuis.Console.White);
30+
31+type
32+ TStdOut = class
33+ private
34+ type
35+ TColoredText = record
36+ private
37+ FStdOut: TStdOut;
38+ FColor: TConsoleColors;
39+ procedure Init(_StdOut: TStdOut; _Color: TConsoleColors);
40+ public
41+ procedure Write(const _Text: string); overload;
42+ procedure Write(const _Format: string; const _Params: array of const); overload;
43+ procedure WriteLn(const _Text: string); overload;
44+ procedure WriteLn(const _Format: string; const _Params: array of const); overload;
45+ end;
46+ private
47+ function GetTextColor: TConsoleColors;
48+ procedure SetTextColor(_Color: TConsoleColors);
49+ public
50+ Error: TColoredText;
51+ Warning: TColoredText;
52+ Hint: TColoredText;
53+ Success: TColoredText;
54+ constructor Create(_ErrorColor: TConsoleColors = ccLightRed;
55+ _WarningColor: TConsoleColors = ccYellow;
56+ _HintColor: TConsoleColors = ccWhite;
57+ _SuccessColor: TConsoleColors = ccLightGreen;
58+ _DefaultColor: TConsoleColors = ccLightGray);
59+ destructor Destroy; override;
60+
61+ procedure Write(const _Text: string); overload;
62+ procedure Write(const _Format: string; const _Params: array of const); overload;
63+ procedure Write(_Color: TConsoleColors; const _Text: string); overload;
64+ procedure Write(_Color: TConsoleColors; const _Format: string; const _Params: array of const); overload;
65+
66+ procedure WriteLn(const _Text: string); overload;
67+ procedure WriteLn(const _Format: string; const _Params: array of const); overload;
68+ procedure WriteLn(_Color: TConsoleColors; const _Text: string); overload;
69+ procedure WriteLn(_Color: TConsoleColors; const _Format: string; const _Params: array of const); overload;
70+
71+ procedure Pause(const _Msg: string = '');
72+ end;
73+
74+var
75+ StdOut: TStdOut = nil;
76+
77+implementation
78+
79+{ TStdOut }
80+
81+constructor TStdOut.Create(_ErrorColor: TConsoleColors = ccLightRed;
82+ _WarningColor: TConsoleColors = ccYellow;
83+ _HintColor: TConsoleColors = ccWhite;
84+ _SuccessColor: TConsoleColors = ccLightGreen;
85+ _DefaultColor: TConsoleColors = ccLightGray);
86+begin
87+ inherited Create;
88+ Error.Init(Self, _ErrorColor);
89+ Warning.Init(Self, _WarningColor);
90+ Hint.Init(Self, _HintColor);
91+ Success.Init(Self, _SuccessColor);
92+
93+ Velthuis.Console.TextBackground(Black);
94+ SetTextColor(_DefaultColor);
95+end;
96+
97+destructor TStdOut.Destroy;
98+begin
99+ inherited;
100+end;
101+
102+function TStdOut.GetTextColor: TConsoleColors;
103+begin
104+ Result := TConsoleColors(Velthuis.Console.TextColor);
105+end;
106+
107+procedure TStdOut.Pause(const _Msg: string = '');
108+begin
109+ Velthuis.Console.Pause(_Msg)
110+end;
111+
112+procedure TStdOut.SetTextColor(_Color: TConsoleColors);
113+begin
114+ Velthuis.Console.TextColor(Ord(_Color));
115+end;
116+
117+procedure TStdOut.Write(const _Text: string);
118+begin
119+ System.Write(Output, _Text);
120+end;
121+
122+procedure TStdOut.Write(const _Format: string; const _Params: array of const);
123+begin
124+ Self.Write(Format(_Format, _Params));
125+end;
126+
127+procedure TStdOut.Write(_Color: TConsoleColors; const _Text: string);
128+var
129+ LastColor: TConsoleColors;
130+begin
131+ LastColor := GetTextColor;
132+ SetTextColor(_Color);
133+ Self.Write(_Text);
134+ SetTextColor(LastColor);
135+end;
136+
137+procedure TStdOut.Write(_Color: TConsoleColors; const _Format: string; const _Params: array of const);
138+begin
139+ Self.Write(_Color, Format(_Format, _Params));
140+end;
141+
142+procedure TStdOut.WriteLn(const _Text: string);
143+begin
144+ System.WriteLn(Output, _Text);
145+end;
146+
147+procedure TStdOut.WriteLn(const _Format: string; const _Params: array of const);
148+begin
149+ Self.WriteLn(Format(_Format, _Params));
150+end;
151+
152+procedure TStdOut.WriteLn(_Color: TConsoleColors; const _Text: string);
153+var
154+ LastColor: TConsoleColors;
155+begin
156+ LastColor := GetTextColor;
157+ SetTextColor(_Color);
158+ Self.WriteLn(_Text);
159+ SetTextColor(LastColor);
160+end;
161+
162+procedure TStdOut.WriteLn(_Color: TConsoleColors; const _Format: string; const _Params: array of const);
163+begin
164+ Self.WriteLn(_Color, Format(_Format, _Params));
165+end;
166+
167+{ TStdOut.TColoredText }
168+
169+procedure TStdOut.TColoredText.Init(_StdOut: TStdOut; _Color: TConsoleColors);
170+begin
171+ FStdOut := _StdOut;
172+ FColor := _Color;
173+end;
174+
175+procedure TStdOut.TColoredText.Write(const _Format: string; const _Params: array of const);
176+begin
177+ FStdOut.Write(FColor, _Format, _Params);
178+end;
179+
180+procedure TStdOut.TColoredText.Write(const _Text: string);
181+begin
182+ FStdOut.Write(FColor, _Text);
183+end;
184+
185+procedure TStdOut.TColoredText.WriteLn(const _Text: string);
186+begin
187+ FStdOut.WriteLn(FColor, _Text);
188+end;
189+
190+procedure TStdOut.TColoredText.WriteLn(const _Format: string; const _Params: array of const);
191+begin
192+ FStdOut.WriteLn(FColor, _Format, _Params);
193+end;
194+
195+initialization
196+ StdOut := TStdOut.Create;
197+finalization
198+ FreeandNil(StdOut);
199+end.
200+
Show on old repository browser