1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 2009 by Sven Barth
FPC Pascal system unit for the WinNT API.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit System;
interface
{$ifdef SYSTEMDEBUG}
{$define SYSTEMEXCEPTIONDEBUG}
{$endif SYSTEMDEBUG}
{$ifdef cpui386}
{$define Set_i386_Exception_handler}
{$endif cpui386}
{$define DISABLE_NO_THREAD_MANAGER}
{$ifdef KMODE}
// in KernelMode we need use a memory manager that just wraps the routines
// provided by the NT Executive and allows to select whether we want to use
// paged or non-paged (use sparely!) memory
{$define HAS_MEMORYMANAGER}
{$endif KMODE}
{ include system-independent routine headers }
{$I systemh.inc}
var
CurrentPeb: Pointer;
IsDeviceDriver: Boolean = False;
const
LineEnding = #13#10;
LFNSupport = true;
DirectorySeparator = '\';
DriveSeparator = '\';
ExtensionSeparator = '.';
PathSeparator = ';';
AllowDirectorySeparators : set of char = ['\'];
AllowDriveSeparators : set of char = [];
{ FileNameCaseSensitive and FileNameCasePreserving are defined separately below!!! }
maxExitCode = High(ErrorCode);
MaxPathLen = High(Word);
AllFilesMask = '*';
type
PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
TEXCEPTION_FRAME = record
next : PEXCEPTION_FRAME;
handler : pointer;
end;
var
{ C compatible arguments }
argc: LongWord;
argvw: PPWideChar;
argv: PPChar;
const
{ Default filehandles }
UnusedHandle : THandle = 0;
StdInputHandle : THandle = 0;
StdOutputHandle : THandle = 0;
StdErrorHandle : THandle = 0;
{$ifndef kmode}
type
TDLL_Entry_Hook = procedure (dllparam : longint);
const
Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil;
Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil;
Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil;
{$endif}
const
// NT is case sensitive
FileNameCaseSensitive : boolean = true;
FileNameCasePreserving: boolean = true;
// todo: check whether this is really the case on NT
CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)
sLineBreak = LineEnding;
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
System_exception_frame : PEXCEPTION_FRAME =nil;
implementation
{ include system independent routines }
{$I system.inc}
function fpc_pwidechar_length(p: PWideChar): SizeInt; external name 'FPC_PWIDECHAR_LENGTH';
{ based on setup_arguments from Win32 RTL }
procedure setup_arguments;
var
i,len,
arglen,
count : longint;
argstart,
pc,arg : pwidechar;
pc2 : pchar;
quote : Boolean;
argvlen : longint;
params : PRTLUserProcessParameters;
procedure allocarg(idx,len:longint);
var
oldargvlen : longint;
begin
if idx>=argvlen then
begin
oldargvlen:=argvlen;
argvlen:=(idx+8) and (not 7);
sysreallocmem(argvw,argvlen*sizeof(pointer));
fillchar(argvw[oldargvlen],(argvlen-oldargvlen)*sizeof(pointer),0);
end;
{ use realloc to reuse already existing memory }
{ always allocate, even if length is zero, since }
{ the arg. is still present! }
sysreallocmem(argvw[idx],len*sizeof(widechar)+2);
end;
begin
{ create commandline, it starts with the executed filename which is argvw[0] }
{ NativeNT passes inside the PEB which is passed on startup }
argvw:=nil;
argv:=nil;
argvlen:=0;
params:=PSimplePEB(CurrentPEB)^.ProcessParameters;
ArgLen:=params^.ImagePathName.Length + 1;
allocarg(0,arglen);
move(params^.ImagePathName.Buffer^,argvw[0]^,arglen*sizeof(widechar)+1);
{ Setup cmdline variable }
{ cmdline is a PChar, but NT uses PWideChar... don't set cmdline for now }
{$message warning 'cmdline is not set'}
// cmdline:=GetCommandLine;
{ the first argument isn't the image file name, so start at 1 }
count:=1;
{ process arguments }
pc:=params^.CommandLine.Buffer;
while pc^<>#0 do
begin
{ skip leading spaces }
while (Ord(pc^) >= 1) and (Ord(pc^) <= 32) {pc^ in [#1..#32]} do
inc(pc);
if pc^=#0 then
break;
{ calc argument length }
quote:=False;
argstart:=pc;
arglen:=0;
while pc^<>#0 do
begin
case pc^ of
#1..#32 :
begin
if quote then
inc(arglen)
else
break;
end;
'"' :
if pc[1]<>'"' then
quote := not quote
else
inc(pc);
else
inc(arglen);
end;
inc(pc);
end;
{ copy argument }
{ Don't copy the first one, it is already there.}
If Count<>0 then
begin
allocarg(count,arglen);
quote:=False;
pc:=argstart;
arg:=argvw[count];
while (pc^<>#0) do
begin
case pc^ of
#1..#32 :
begin
if quote then
begin
arg^:=pc^;
inc(arg);
end
else
break;
end;
'"' :
if pc[1]<>'"' then
quote := not quote
else
inc(pc);
else
begin
arg^:=pc^;
inc(arg);
end;
end;
inc(pc);
end;
arg^:=#0;
end;
inc(count);
end;
{ get argc }
argc:=count;
{ free unused memory, leaving a nil entry at the end }
sysreallocmem(argvw,(count+1)*sizeof(pointer));
argvw[count] := nil;
{ now we need to fill argv with UTF8 encoded arguments }
sysreallocmem(argv,(count+1)*sizeof(pointer));
fillchar(argv^,(count+1)*sizeof(pointer),0);
for i := 0 to count - 1 do begin
len := fpc_pwidechar_length(argvw[i]);
pc := argvw[i];
argv[i]:=nil;
sysreallocmem(argv[i],len+1);
pc2 := argv[i];
{$message warning 'Use UnicodeToUTF8 for argument conversion'}
while Ord(pc^) > 0 do begin
if word(pc^) < 127 then
pc2^ := Char(word(pc^))
else
pc2^ := '?';
Inc(pc);
Inc(pc2);
end;
pc2^ := #0;
end;
end;
function paramcount : longint;
begin
paramcount := argc - 1;
end;
function paramstr(l : longint) : string;
begin
if (l>=0) and (l<argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
procedure KeQueryTickCount(TickCount: PLargeInteger); stdcall; external ntdll name 'KeQueryTickCount';
procedure randomize;
var
tc: PLargeInteger;
begin
FillChar(tc, SizeOf(TLargeInteger), 0);
KeQueryTickCount(@tc);
// the lower part should differ most on system startup
randseed := tc^.LowPart;
end;
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
procedure PascalMain;stdcall;external name 'PASCALMAIN';
{$ifndef KMODE}
function NtTerminateProcess(aProcess: THandle; aStatus: LongInt): LongInt; stdcall; external ntdll name 'NtTerminateProcess';
{$endif KMODE}
Procedure system_exit;
begin
if IsLibrary or IsDeviceDriver then
Exit;
{$ifndef KMODE}
NtTerminateProcess(THandle(-1), ExitCode);
{$endif KMODE}
end;
{$ifdef kmode}
function FPCDriverStartup(aDriverObject: Pointer; aRegistryPath: Pointer): LongInt; [public, alias: 'FPC_DriverStartup'];
begin
IsDeviceDriver := True;
IsConsole := True;
IsLibrary := True;
SysDriverObject := aDriverObject;
SysRegistryPath := aRegistryPath;
PASCALMAIN;
SysDriverObject := Nil;
SysRegistryPath := Nil;
Result := ExitCode;
end;
{$else}
const
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_PROCESS_DETACH = 0;
DLL_THREAD_DETACH = 3;
function FPCDLLEntry(aHInstance: Pointer; aDLLReason: LongInt; aDLLParam: LongInt): LongBool; [public, alias: 'FPC_DLLEntry'];
begin
IsLibrary := True;
FPCDLLEntry := True;
case aDLLReason of
DLL_PROCESS_ATTACH: begin
PascalMain;
FPCDLLEntry := ExitCode = 0;
end;
DLL_THREAD_ATTACH: begin
if Dll_Thread_Attach_Hook <> Nil then
Dll_Thread_Attach_Hook(aDllParam);
end;
DLL_THREAD_DETACH: begin
if Dll_Thread_Detach_Hook <> Nil then
Dll_Thread_Detach_Hook(aDllParam);
end;
DLL_PROCESS_DETACH: begin
if Dll_Process_Detach_Hook <> Nil then
Dll_Process_Detach_Hook(aDllParam);
// finalize units
do_exit;
end;
end;
end;
procedure FPCProcessStartup(aArgument: Pointer);[public, alias: 'FPC_ProcessStartup'];
begin
IsConsole := True;
IsLibrary := False;
CurrentPeb := aArgument;
PASCALMAIN;
system_exit;
end;
{$endif}
{$ifdef kmode}
// Kernel Mode Entry Point
function NtDriverEntry( aDriverObject: Pointer; aRegistryPath: Pointer ): LongInt; stdcall; [public, alias: '_NtDriverEntry'];
begin
NtDriverEntry := FPCDriverStartup(aDriverObject, aRegistryPath);
end;
{$else}
// User Mode Entry Points
procedure NtProcessStartup( aArgument: Pointer ); stdcall; [public, alias: '_NtProcessStartup'];
begin
FPCProcessStartup(aArgument);
end;
function DLLMainStartup( aHInstance: Pointer; aDLLReason, aDLLParam: LongInt ): LongBool; stdcall; [public, alias: '_DLLMainStartup'];
begin
DLLMainStartup := FPCDLLEntry(aHInstance, aDLLReason, aDLLParam);
end;
{$endif}
procedure SysInitStdIO;
begin
{ This function is currently only called if the RTL is compiled for Usermode;
one could think about adding a text driver that outputs using DbgPrint }
{$ifndef KMODE}
with PSimplePEB(CurrentPEB)^.ProcessParameters^ do begin
StdInputHandle := StandardInput;
StdOutputHandle := StandardOutput;
StdErrorHandle := StandardError;
end;
if StdInputHandle <> 0 then
OpenStdIO(Input, fmInput, StdInputHandle)
else
Assign(Input, '');
if StdOutputHandle <> 0 then begin
OpenStdIO(Output, fmOutput, StdOutputHandle);
OpenStdIO(StdOut, fmOutput, StdOutputHandle);
end else begin
Assign(Output, '');
Assign(StdOut, '');
end;
if StdErrorHandle <> 0 then begin
OpenStdIO(ErrOutput, fmOutput, StdErrorHandle);
OpenStdIO(StdErr, fmOutput, StdErrorHandle);
end else begin
Assign(ErrOutput, '');
Assign(StdErr, '');
end;
{$endif}
end;
function GetProcessID: SizeUInt;
begin
{$ifdef kmode}
// it might be that we can detect the user process that called us,
// but that needs to be checked... so for now just return 0
Result := 0;
{$else}
Result := NtCurrentTEB^.ClientID.UniqueProcess;
{$endif}
end;
begin
{$if not defined(KMODE) and not defined(HAS_MEMORYMANAGER)}
{ Setup heap }
InitHeap;
{$endif ndef KMODE and ndef HAS_MEMORYMANAGER}
SysInitExceptions;
initvariantmanager;
{ we do not use winlike widestrings and also the RTL can't be compiled with
2.2, so we can savely use the UnicodeString manager only. }
initunicodestringmanager;
{$ifndef KMODE}
SysInitStdIO;
{ Arguments }
setup_arguments;
{$endif}
InOutRes := 0;
InitSystemThreads;
errno := 0;
end.
|