← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to rtl/morphos/sysutils.pp

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2005-05-30 11:59:10 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050530115910-x5pbzm4qqta4i94h
Tags: 2.0.0-2
http://bugs.debian.org/310907
debian/fp-compiler.postinst.in: forgot to reapply the patch that
correctly creates the slave link to pc(1).  (Closes: #310907)

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/morphos/sysutils.pp
 
1
{
 
2
    $Id: sysutils.pp,v 1.7 2005/02/26 14:38:14 florian Exp $
 
3
 
 
4
    This file is part of the Free Pascal run time library.
 
5
    Copyright (c) 2004 by Karoly Balogh
 
6
 
 
7
    Sysutils unit for MorphOS
 
8
 
 
9
    Based on Amiga version by Carl Eric Codere, and other
 
10
    parts of the RTL
 
11
 
 
12
    See the file COPYING.FPC, included in this distribution,
 
13
    for details about the copyright.
 
14
 
 
15
    This program is distributed in the hope that it will be useful,
 
16
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
17
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
18
 
 
19
 **********************************************************************}
 
20
 
 
21
unit sysutils;
 
22
 
 
23
interface
 
24
 
 
25
{$MODE objfpc}
 
26
{ force ansistrings }
 
27
{$H+}
 
28
 
 
29
{ Include platform independent interface part }
 
30
{$i sysutilh.inc}
 
31
 
 
32
{ Platform dependent calls }
 
33
 
 
34
Procedure AddDisk(const path:string);
 
35
 
 
36
 
 
37
implementation
 
38
 
 
39
uses dos,sysconst;
 
40
 
 
41
{ Include platform independent implementation part }
 
42
{$i sysutils.inc}
 
43
 
 
44
 
 
45
{ * Include MorphOS specific includes * }
 
46
{$include execd.inc}
 
47
{$include execf.inc}
 
48
{$include timerd.inc}
 
49
{$include doslibd.inc}
 
50
{$include doslibf.inc}
 
51
{$include utilf.inc}
 
52
 
 
53
{ * Followings are implemented in the system unit! * }
 
54
function PathConv(path: shortstring): shortstring; external name 'PATHCONV';
 
55
procedure AddToList(var l: Pointer; h: LongInt); external name 'ADDTOLIST';
 
56
procedure RemoveFromList(var l: Pointer; h: LongInt); external name 'REMOVEFROMLIST';
 
57
 
 
58
var
 
59
  MOS_fileList: Pointer; external name 'MOS_FILELIST';
 
60
 
 
61
 
 
62
{****************************************************************************
 
63
                              File Functions
 
64
****************************************************************************}
 
65
{$I-}{ Required for correct usage of these routines }
 
66
 
 
67
 
 
68
(****** non portable routines ******)
 
69
 
 
70
function FileOpen(const FileName: string; Mode: Integer): LongInt;
 
71
var
 
72
  dosResult: LongInt;
 
73
  tmpStr   : array[0..255] of char;
 
74
begin
 
75
  {$WARNING FIX ME! To do: FileOpen Access Modes}
 
76
  tmpStr:=PathConv(FileName)+#0;
 
77
  dosResult:=Open(@tmpStr,MODE_OLDFILE);
 
78
  if dosResult=0 then
 
79
    dosResult:=-1
 
80
  else
 
81
    AddToList(MOS_fileList,dosResult);
 
82
 
 
83
  FileOpen:=dosResult;
 
84
end;
 
85
 
 
86
 
 
87
function FileGetDate(Handle: LongInt) : LongInt;
 
88
begin
 
89
end;
 
90
 
 
91
 
 
92
function FileSetDate(Handle, Age: LongInt) : LongInt;
 
93
begin
 
94
  // Impossible under unix from FileHandle !!
 
95
  FileSetDate:=-1;
 
96
end;
 
97
 
 
98
 
 
99
function FileCreate(const FileName: string) : LongInt;
 
100
var
 
101
  dosResult: LongInt;
 
102
  tmpStr   : array[0..255] of char;
 
103
begin
 
104
 tmpStr:=PathConv(FileName)+#0;
 
105
 dosResult:=Open(@tmpStr,MODE_NEWFILE);
 
106
 if dosResult=0 then
 
107
   dosResult:=-1
 
108
 else
 
109
   AddToList(MOS_fileList,dosResult);
 
110
 
 
111
 FileCreate:=dosResult;
 
112
end;
 
113
 
 
114
 
 
115
function FileCreate(const FileName: string; Mode: integer): LongInt;
 
116
begin
 
117
  {$WARNING FIX ME! To do: FileCreate Access Modes}
 
118
  FileCreate:=FileCreate(FileName);
 
119
end;
 
120
 
 
121
 
 
122
function FileRead(Handle: LongInt; var Buffer; Count: LongInt): LongInt;
 
123
begin
 
124
  FileRead:=-1;
 
125
  if (Count<=0) or (Handle<=0) then exit;
 
126
 
 
127
  FileRead:=dosRead(Handle,@Buffer,Count);
 
128
end;
 
129
 
 
130
 
 
131
function FileWrite(Handle: LongInt; const Buffer; Count: LongInt): LongInt;
 
132
begin
 
133
  FileWrite:=-1;
 
134
  if (Count<=0) or (Handle<=0) then exit;
 
135
 
 
136
  FileWrite:=dosWrite(Handle,@Buffer,Count);
 
137
end;
 
138
 
 
139
 
 
140
function FileSeek(Handle, FOffset, Origin: LongInt) : LongInt;
 
141
var
 
142
  seekMode: LongInt;
 
143
begin
 
144
  FileSeek:=-1;
 
145
  if (Handle<=0) then exit;
 
146
 
 
147
  case Origin of
 
148
    fsFromBeginning: seekMode:=OFFSET_BEGINNING;
 
149
    fsFromCurrent  : seekMode:=OFFSET_CURRENT;
 
150
    fsFromEnd      : seekMode:=OFFSET_END;
 
151
  end;
 
152
 
 
153
  FileSeek:=dosSeek(Handle, FOffset, seekMode);
 
154
end;
 
155
 
 
156
function FileSeek(Handle: LongInt; FOffset, Origin: Int64): Int64;
 
157
begin
 
158
  {$WARNING Need to add 64bit call }
 
159
  FileSeek:=FileSeek(Handle,LongInt(FOffset),LongInt(Origin));
 
160
end;
 
161
 
 
162
 
 
163
procedure FileClose(Handle: LongInt);
 
164
begin
 
165
  if (Handle<=0) then exit;
 
166
 
 
167
  dosClose(Handle);
 
168
  RemoveFromList(MOS_fileList,Handle);
 
169
end;
 
170
 
 
171
 
 
172
function FileTruncate(Handle, Size: LongInt): Boolean;
 
173
var
 
174
  dosResult: LongInt;
 
175
begin
 
176
  FileTruncate:=False;
 
177
  if (Handle<=0) then exit;
 
178
 
 
179
  dosResult:=SetFileSize(Handle, Size, OFFSET_BEGINNING);
 
180
  if (dosResult<0) then exit;
 
181
 
 
182
  FileTruncate:=True;
 
183
end;
 
184
 
 
185
 
 
186
function DeleteFile(const FileName: string) : Boolean;
 
187
var
 
188
  tmpStr: array[0..255] of char;
 
189
begin
 
190
  tmpStr:=PathConv(FileName)+#0;
 
191
 
 
192
  DeleteFile:=dosDeleteFile(@tmpStr);
 
193
end;
 
194
 
 
195
 
 
196
function RenameFile(const OldName, NewName: string): Boolean;
 
197
var
 
198
  tmpOldName, tmpNewName: array[0..255] of char;
 
199
begin
 
200
  tmpOldName:=PathConv(OldName)+#0;
 
201
  tmpNewName:=PathConv(NewName)+#0;
 
202
 
 
203
  RenameFile:=dosRename(tmpOldName, tmpNewName);
 
204
end;
 
205
 
 
206
 
 
207
(****** end of non portable routines ******)
 
208
 
 
209
 
 
210
Function FileAge (Const FileName : String): Longint;
 
211
 
 
212
var F: file;
 
213
    Time: longint;
 
214
begin
 
215
   Assign(F,FileName);
 
216
   dos.GetFTime(F,Time);
 
217
   { Warning this is not compatible with standard routines
 
218
     since Double are not supported on m68k by default!
 
219
   }
 
220
   FileAge:=Time;
 
221
end;
 
222
 
 
223
 
 
224
Function FileExists (Const FileName : String) : Boolean;
 
225
Var
 
226
 F: File;
 
227
 OldMode : Byte;
 
228
Begin
 
229
  OldMode := FileMode;
 
230
  FileMode := fmOpenRead;
 
231
  Assign(F,FileName);
 
232
  Reset(F,1);
 
233
  FileMode := OldMode;
 
234
  If IOResult <> 0 then
 
235
    FileExists := FALSE
 
236
  else
 
237
    Begin
 
238
      FileExists := TRUE;
 
239
      Close(F);
 
240
    end;
 
241
end;
 
242
 
 
243
type
 
244
  PDOSSearchRec = ^SearchRec;
 
245
 
 
246
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
 
247
Const
 
248
  faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
 
249
var
 
250
  p : pDOSSearchRec;
 
251
  dosattr: word;
 
252
  DT: Datetime;
 
253
begin
 
254
 dosattr:=0;
 
255
 if Attr and faHidden <> 0 then
 
256
   dosattr := dosattr or Hidden;
 
257
 if Attr and faSysFile <> 0 then
 
258
   dosattr := dosattr or SysFile;
 
259
 if Attr and favolumeID <> 0 then
 
260
   dosattr := dosattr or VolumeID;
 
261
 if Attr and faDirectory <> 0 then
 
262
   dosattr := dosattr or Directory;
 
263
 New(p);
 
264
 Rslt.FindHandle :=  THandle(p);
 
265
 dos.FindFirst(path,dosattr,p^);
 
266
 if DosError <> 0 then
 
267
    begin
 
268
      FindFirst := -1;
 
269
    end
 
270
 else
 
271
   begin
 
272
     Rslt.Name := p^.Name;
 
273
     { Not compatible with other platforms! }
 
274
     Rslt.Time:=p^.Time;
 
275
     Rslt.Attr := p^.Attr;
 
276
     Rslt.ExcludeAttr := not p^.Attr;
 
277
     Rslt.Size := p^.Size;
 
278
     FindFirst := 0;
 
279
   end;
 
280
end;
 
281
 
 
282
 
 
283
Function FindNext (Var Rslt : TSearchRec) : Longint;
 
284
var
 
285
 p : pDOSSearchRec;
 
286
 DT: Datetime;
 
287
begin
 
288
  p:= PDOsSearchRec(Rslt.FindHandle);
 
289
  if not assigned(p) then
 
290
     begin
 
291
       FindNext := -1;
 
292
       exit;
 
293
     end;
 
294
  Dos.FindNext(p^);
 
295
 if DosError <> 0 then
 
296
    begin
 
297
      FindNext := -1;
 
298
    end
 
299
 else
 
300
   begin
 
301
     Rslt.Name := p^.Name;
 
302
     UnpackTime(p^.Time, DT);
 
303
     { Warning: Not compatible with other platforms }
 
304
     Rslt.time := p^.Time;
 
305
     Rslt.Attr := p^.Attr;
 
306
     Rslt.ExcludeAttr := not p^.Attr;
 
307
     Rslt.Size := p^.Size;
 
308
     FindNext := 0;
 
309
   end;
 
310
end;
 
311
 
 
312
Procedure FindClose (Var F : TSearchrec);
 
313
Var
 
314
  p : PDOSSearchRec;
 
315
 
 
316
begin
 
317
  p:=PDOSSearchRec(f.FindHandle);
 
318
  if not assigned(p) then
 
319
       exit;
 
320
  Dos.FindClose(p^);
 
321
  if assigned(p) then
 
322
     Dispose(p);
 
323
  f.FindHandle := THandle(nil);
 
324
end;
 
325
 
 
326
Function FileGetAttr (Const FileName : String) : Longint;
 
327
var
 
328
 F: file;
 
329
 attr: word;
 
330
begin
 
331
 Assign(F,FileName);
 
332
 dos.GetFAttr(F,attr);
 
333
 if DosError <> 0 then
 
334
    FileGetAttr := -1
 
335
 else
 
336
    FileGetAttr := Attr;
 
337
end;
 
338
 
 
339
 
 
340
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
 
341
var
 
342
 F: file;
 
343
begin
 
344
 Assign(F, FileName);
 
345
 Dos.SetFAttr(F, Attr and $ffff);
 
346
 FileSetAttr := DosError;
 
347
end;
 
348
 
 
349
 
 
350
 
 
351
{****************************************************************************
 
352
                              Disk Functions
 
353
****************************************************************************}
 
354
 
 
355
{
 
356
  The Diskfree and Disksize functions need a file on the specified drive, since this
 
357
  is required for the statfs system call.
 
358
  These filenames are set in drivestr[0..26], and have been preset to :
 
359
   0 - '.'      (default drive - hence current dir is ok.)
 
360
   1 - '/fd0/.'  (floppy drive 1 - should be adapted to local system )
 
361
   2 - '/fd1/.'  (floppy drive 2 - should be adapted to local system )
 
362
   3 - '/'       (C: equivalent of dos is the root partition)
 
363
   4..26          (can be set by you're own applications)
 
364
  ! Use AddDisk() to Add new drives !
 
365
  They both return -1 when a failure occurs.
 
366
}
 
367
Const
 
368
  FixDriveStr : array[0..3] of pchar=(
 
369
    '.',
 
370
    '/fd0/.',
 
371
    '/fd1/.',
 
372
    '/.'
 
373
    );
 
374
var
 
375
  Drives   : byte;
 
376
  DriveStr : array[4..26] of pchar;
 
377
 
 
378
Procedure AddDisk(const path:string);
 
379
begin
 
380
  if not (DriveStr[Drives]=nil) then
 
381
   FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
 
382
  GetMem(DriveStr[Drives],length(Path)+1);
 
383
  StrPCopy(DriveStr[Drives],path);
 
384
  inc(Drives);
 
385
  if Drives>26 then
 
386
   Drives:=4;
 
387
end;
 
388
 
 
389
 
 
390
 
 
391
Function DiskFree(Drive: Byte): int64;
 
392
Begin
 
393
  DiskFree := dos.diskFree(Drive);
 
394
End;
 
395
 
 
396
 
 
397
Function DiskSize(Drive: Byte): int64;
 
398
Begin
 
399
  DiskSize := dos.DiskSize(Drive);
 
400
End;
 
401
 
 
402
 
 
403
Function GetCurrentDir : String;
 
404
begin
 
405
  GetDir (0,Result);
 
406
end;
 
407
 
 
408
 
 
409
Function SetCurrentDir (Const NewDir : String) : Boolean;
 
410
begin
 
411
   ChDir(NewDir);
 
412
  result := (IOResult = 0);
 
413
end;
 
414
 
 
415
 
 
416
Function CreateDir (Const NewDir : String) : Boolean;
 
417
begin
 
418
   MkDir(NewDir);
 
419
  result := (IOResult = 0);
 
420
end;
 
421
 
 
422
 
 
423
Function RemoveDir (Const Dir : String) : Boolean;
 
424
begin
 
425
   RmDir(Dir);
 
426
  result := (IOResult = 0);
 
427
end;
 
428
 
 
429
 
 
430
Function DirectoryExists(const Directory: string): Boolean;
 
431
var
 
432
 s: string;
 
433
begin
 
434
  { Get old directory }
 
435
  s:=GetCurrentDir;
 
436
  ChDir(Directory);
 
437
  DirectoryExists := (IOResult = 0);
 
438
  ChDir(s);
 
439
end;
 
440
 
 
441
 
 
442
{****************************************************************************
 
443
                              Misc Functions
 
444
****************************************************************************}
 
445
 
 
446
procedure Beep;
 
447
begin
 
448
end;
 
449
 
 
450
 
 
451
{****************************************************************************
 
452
                              Locale Functions
 
453
****************************************************************************}
 
454
 
 
455
Procedure GetLocalTime(var SystemTime: TSystemTime);
 
456
var
 
457
 dayOfWeek: word;
 
458
begin
 
459
  dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second,SystemTime.Millisecond);
 
460
  dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, DayOfWeek);
 
461
end ;
 
462
 
 
463
 
 
464
Procedure InitAnsi;
 
465
Var
 
466
  i : longint;
 
467
begin
 
468
  {  Fill table entries 0 to 127  }
 
469
  for i := 0 to 96 do
 
470
    UpperCaseTable[i] := chr(i);
 
471
  for i := 97 to 122 do
 
472
    UpperCaseTable[i] := chr(i - 32);
 
473
  for i := 123 to 191 do
 
474
    UpperCaseTable[i] := chr(i);
 
475
  Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
 
476
 
 
477
  for i := 0 to 64 do
 
478
    LowerCaseTable[i] := chr(i);
 
479
  for i := 65 to 90 do
 
480
    LowerCaseTable[i] := chr(i + 32);
 
481
  for i := 91 to 191 do
 
482
    LowerCaseTable[i] := chr(i);
 
483
  Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
 
484
end;
 
485
 
 
486
 
 
487
Procedure InitInternational;
 
488
begin
 
489
  InitInternationalGeneric; 
 
490
  InitAnsi;
 
491
end;
 
492
 
 
493
function SysErrorMessage(ErrorCode: Integer): String;
 
494
 
 
495
begin
 
496
{  Result:=StrError(ErrorCode);}
 
497
end;
 
498
 
 
499
{****************************************************************************
 
500
                              OS utility functions
 
501
****************************************************************************}
 
502
 
 
503
Function GetEnvironmentVariable(Const EnvVar : String) : String;
 
504
 
 
505
begin
 
506
  Result:=Dos.Getenv(shortstring(EnvVar));
 
507
end;
 
508
Function GetEnvironmentVariableCount : Integer;
 
509
 
 
510
begin
 
511
  // Result:=FPCCountEnvVar(EnvP);
 
512
  Result:=Dos.envCount;
 
513
end;
 
514
 
 
515
Function GetEnvironmentString(Index : Integer) : String;
 
516
 
 
517
begin
 
518
  // Result:=FPCGetEnvStrFromP(Envp,Index);
 
519
  Result:=Dos.EnvStr(Index);
 
520
end;
 
521
 
 
522
function ExecuteProcess (const Path: AnsiString; const ComLine: AnsiString):
 
523
                                                                       integer;
 
524
var
 
525
  CommandLine: AnsiString;
 
526
  E: EOSError;
 
527
 
 
528
begin
 
529
  Dos.Exec (Path, ComLine);
 
530
  if DosError <> 0 then begin
 
531
 
 
532
    if ComLine = '' then
 
533
      CommandLine := Path
 
534
    else
 
535
      CommandLine := Path + ' ' + ComLine;
 
536
 
 
537
    E := EOSError.CreateFmt (SExecuteProcessFailed, [CommandLine, DosError]);
 
538
    E.ErrorCode := DosError;
 
539
    raise E;
 
540
  end;
 
541
end;
 
542
 
 
543
function ExecuteProcess (const Path: AnsiString;
 
544
                                  const ComLine: array of AnsiString): integer;
 
545
var
 
546
  CommandLine: AnsiString;
 
547
  I: integer;
 
548
 
 
549
begin
 
550
  Commandline := '';
 
551
  for I := 0 to High (ComLine) do
 
552
   if Pos (' ', ComLine [I]) <> 0 then
 
553
    CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
 
554
   else
 
555
    CommandLine := CommandLine + ' ' + Comline [I];
 
556
  ExecuteProcess := ExecuteProcess (Path, CommandLine);
 
557
end;
 
558
 
 
559
 
 
560
{****************************************************************************
 
561
                              Initialization code
 
562
****************************************************************************}
 
563
 
 
564
Initialization
 
565
  InitExceptions;
 
566
  InitInternational;    { Initialize internationalization settings }
 
567
Finalization
 
568
  DoneExceptions;
 
569
end.
 
570
{
 
571
    $Log: sysutils.pp,v $
 
572
    Revision 1.7  2005/02/26 14:38:14  florian
 
573
      + SysLocale
 
574
 
 
575
    Revision 1.6  2005/02/14 17:13:30  peter
 
576
      * truncate log
 
577
 
 
578
    Revision 1.5  2005/01/30 02:36:14  karoly
 
579
      * fixed compilation
 
580
 
 
581
    Revision 1.4  2005/01/12 08:03:42  karoly
 
582
      * Few more Sysutils functions implemented
 
583
 
 
584
    Revision 1.3  2005/01/11 17:44:06  karoly
 
585
      * basic file I/O implemented
 
586
 
 
587
}