← Back to branch summary

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

« back to all changes in this revision

Viewing changes to rtl/posix/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/posix/sysutils.pp
1
 
{
2
 
    $Id: sysutils.pp,v 1.9 2003/11/26 20:00:19 florian Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 1999-2001 by Florian Klaempfl
5
 
    member of the Free Pascal development team
6
 
 
7
 
    Sysutils unit for POSIX compliant systems
8
 
 
9
 
    See the file COPYING.FPC, included in this distribution,
10
 
    for details about the copyright.
11
 
 
12
 
    This program is distributed in the hope that it will be useful,
13
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15
 
 
16
 
 **********************************************************************}
17
 
unit sysutils;
18
 
interface
19
 
 
20
 
{$MODE objfpc}
21
 
{ force ansistrings }
22
 
{$H+}
23
 
 
24
 
 
25
 
{ Include platform independent interface part }
26
 
{$i sysutilh.inc}
27
 
 
28
 
{ Platform dependent calls }
29
 
 
30
 
Procedure AddDisk(const path:string);
31
 
 
32
 
implementation
33
 
 
34
 
  uses
35
 
    sysconst,dos,posix;
36
 
 
37
 
{ Include platform independent implementation part }
38
 
{$i sysutils.inc}
39
 
 
40
 
 
41
 
 
42
 
{****************************************************************************
43
 
                              File Functions
44
 
****************************************************************************}
45
 
{$I-}
46
 
const
47
 
     { read/write permission for everyone }
48
 
     MODE_OPEN = S_IWUSR OR S_IRUSR OR
49
 
                 S_IWGRP OR S_IRGRP OR
50
 
                 S_IWOTH OR S_IROTH;
51
 
 
52
 
 
53
 
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
54
 
 
55
 
Var Flags : cint;
56
 
    FileHandle : cint;
57
 
{    lock: flock;}
58
 
BEGIN
59
 
  Flags:=0;
60
 
  Case (Mode and 3) of
61
 
    fmOpenRead : Flags:=Flags or O_RDONLY;
62
 
    fmOpenWrite : Flags:=Flags or O_WRONLY;
63
 
    fmOpenReadWrite : Flags:=Flags or O_RDWR;
64
 
  end;
65
 
  FileHandle:=sys_Open (pchar(FileName),Flags,MODE_OPEN);
66
 
  if (ErrNo=Sys_EROFS) and ((Flags and O_RDWR)<>0) then
67
 
   begin
68
 
     Flags:=Flags and not(O_RDWR);
69
 
     FileHandle:=sys_open(pchar(FileName),Flags,MODE_OPEN);
70
 
   end;
71
 
  FileOpen := longint(FileHandle);
72
 
(*
73
 
  { if there was an error, then don't do anything }
74
 
  if FileHandle = -1 then
75
 
     exit;
76
 
  { now check if the file can actually be used }
77
 
  { by verifying the locks on the file         }
78
 
  lock.l_whence := SEEK_SET;
79
 
  lock.l_start := 0; { from start of file }
80
 
  lock.l_len := 0;   { to END of file    }
81
 
  if sys_fcntl(FileHandle, F_GETLK, @lock)<>-1 then
82
 
    begin
83
 
        { if another process has created a lock on this file }
84
 
        { exclusive lock? }
85
 
        if (lock.l_type = F_WRLCK) then
86
 
           begin
87
 
             { close and exit }
88
 
             sys_close(FileHandle);
89
 
             FileOpen := -1;
90
 
             exit;
91
 
           end;
92
 
        { shared lock? }
93
 
        if (lock.l_type = F_RDLK) and
94
 
          ((Flags = O_RDWR) or Flags = O_WRONLY)) then
95
 
           begin
96
 
             { close and exit }
97
 
             sys_close(FileHandle);
98
 
             FileOpen := -1;
99
 
             exit;
100
 
           end;
101
 
    end;
102
 
  { now actually set the lock: }
103
 
  { only the following are simulated with sysutils : }
104
 
  {  - fmShareDenywrite (get exclusive lock)         }
105
 
  {  - fmShareExclusive (get exclusive lock)         }
106
 
  if ((Mode and fmShareDenyWrite)<>0) or
107
 
     ((Mode and fmShareExclusive)<>0) then
108
 
    begin
109
 
      lock.l_whence := SEEK_SET;
110
 
      lock.l_start := 0; { from stat of file    }
111
 
      lock.l_len := 0;   { to END of file       }
112
 
      lock.l_type := F_WRLCK;  { exclusive lock }
113
 
      if sys_fcntl(FileHandle, F_SETLK, @lock)=-1 then
114
 
        begin
115
 
          sys_close(FileHandel);
116
 
          FileOpen := -1;
117
 
          exit;
118
 
        end;
119
 
    end;
120
 
*)
121
 
end;
122
 
 
123
 
 
124
 
Function FileCreate (Const FileName : String) : Longint;
125
 
 
126
 
begin
127
 
  FileCreate:=sys_Open(pchar(FileName),O_RDWR or O_CREAT or O_TRUNC,MODE_OPEN);
128
 
end;
129
 
 
130
 
 
131
 
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
132
 
 
133
 
begin
134
 
  repeat
135
 
    FileRead:=sys_read(Handle,pchar(@Buffer),Count);
136
 
  until ErrNo<>Sys_EINTR;
137
 
  If FileRead = -1 then
138
 
    FileRead := 0;
139
 
end;
140
 
 
141
 
 
142
 
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
143
 
 
144
 
begin
145
 
  repeat
146
 
    FileWrite:=sys_write(Handle,pchar(@Buffer),Count);
147
 
  until ErrNo<>Sys_EINTR;
148
 
  if FileWrite = -1 then
149
 
    FileWrite := 0;
150
 
end;
151
 
 
152
 
 
153
 
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
154
 
var
155
 
 whence : cint;
156
 
begin
157
 
  FileSeek := -1;
158
 
  case Origin of
159
 
  { from beginning of file }
160
 
  0 :  whence := SEEK_SET;
161
 
  { from current position }
162
 
  1 :  whence := SEEK_CUR;
163
 
  { from end of file       }
164
 
  2 :  whence := SEEK_END;
165
 
  else
166
 
   exit;
167
 
  end;
168
 
  FileSeek := sys_lseek(Handle,FOffset,whence);
169
 
  if errno <> 0 then
170
 
   FileSeek := -1;
171
 
end;
172
 
 
173
 
 
174
 
Procedure FileClose (Handle : Longint);
175
 
 
176
 
begin
177
 
  sys_close(Handle);
178
 
end;
179
 
 
180
 
Function FileTruncate (Handle,Size: Longint) : boolean;
181
 
 
182
 
begin
183
 
  if sys_ftruncate(Handle,Size)=0 then
184
 
    FileTruncate := true
185
 
  else
186
 
    FileTruncate := false;
187
 
end;
188
 
 
189
 
 
190
 
Function FileAge (Const FileName : String): Longint;
191
 
 
192
 
var F: file;
193
 
    Time: longint;
194
 
begin
195
 
   Assign(F,FileName);
196
 
   Reset(F,1);
197
 
   dos.GetFTime(F,Time);
198
 
   Close(F);
199
 
   FileAge := Time;
200
 
end;
201
 
 
202
 
 
203
 
Function FileExists (Const FileName : String) : Boolean;
204
 
 
205
 
Var Info : Stat;
206
 
 
207
 
begin
208
 
  if sys_stat(pchar(filename),Info)<>0 then
209
 
    FileExists := false
210
 
  else
211
 
    FileExists := true;
212
 
end;
213
 
 
214
 
 
215
 
Function UNIXToWinAttr (FN : Pchar; Const Info : Stat) : Longint;
216
 
 
217
 
begin
218
 
  Result:=faArchive;
219
 
  If S_ISDIR(Info.st_mode) then
220
 
    Result:=Result or faDirectory ;
221
 
  If (FN[0]='.') and (not (FN[1] in [#0,'.']))  then
222
 
    Result:=Result or faHidden;
223
 
  if (info.st_mode and S_IWUSR)=0 then
224
 
    Result:=Result or fareadonly;
225
 
  If S_ISREG(Info.st_Mode) Then
226
 
     Result:=Result or faSysFile;
227
 
end;
228
 
 
229
 
 
230
 
 
231
 
 
232
 
type
233
 
  PDOSSearchRec = ^SearchRec;
234
 
 
235
 
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
236
 
 
237
 
Const
238
 
  faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
239
 
var
240
 
  p : pDOSSearchRec;
241
 
  dosattr: word;
242
 
begin
243
 
 dosattr:=0;
244
 
 if Attr and faHidden <> 0 then
245
 
   dosattr := dosattr or Hidden;
246
 
 if Attr and faSysFile <> 0 then
247
 
   dosattr := dosattr or SysFile;
248
 
 if Attr and favolumeID <> 0 then
249
 
   dosattr := dosattr or VolumeID;
250
 
 if Attr and faDirectory <> 0 then
251
 
   dosattr := dosattr or faDirectory;
252
 
 New(p);
253
 
 Rslt.FindHandle :=  THandle(p);
254
 
 dos.FindFirst(path,dosattr,p^);
255
 
 if DosError <> 0 then
256
 
    begin
257
 
      FindFirst := -1;
258
 
    end
259
 
 else
260
 
   begin
261
 
     Rslt.Name := p^.Name;
262
 
     Rslt.Time := p^.Time;
263
 
     Rslt.Attr := p^.Attr;
264
 
     Rslt.ExcludeAttr := not p^.Attr;
265
 
     Rslt.Size := p^.Size;
266
 
     FindFirst := 0;
267
 
   end;
268
 
end;
269
 
 
270
 
 
271
 
Function FindNext (Var Rslt : TSearchRec) : Longint;
272
 
var
273
 
 p : pDOSSearchRec;
274
 
begin
275
 
  p:= PDOsSearchRec(Rslt.FindHandle);
276
 
  if not assigned(p) then
277
 
     begin
278
 
       FindNext := -1;
279
 
       exit;
280
 
     end;
281
 
  Dos.FindNext(p^);
282
 
 if DosError <> 0 then
283
 
    begin
284
 
      FindNext := -1;
285
 
    end
286
 
 else
287
 
   begin
288
 
     Rslt.Name := p^.Name;
289
 
     Rslt.Time := p^.Time;
290
 
     Rslt.Attr := p^.Attr;
291
 
     Rslt.ExcludeAttr := not p^.Attr;
292
 
     Rslt.Size := p^.Size;
293
 
     FindNext := 0;
294
 
   end;
295
 
end;
296
 
 
297
 
 
298
 
Procedure FindClose (Var F : TSearchrec);
299
 
 
300
 
Var
301
 
  p : PDOSSearchRec;
302
 
 
303
 
begin
304
 
  p:=PDOSSearchRec(f.FindHandle);
305
 
  if not assigned(p) then
306
 
       exit;
307
 
  Dos.FindClose(p^);
308
 
  if assigned(p) then
309
 
     Dispose(p);
310
 
  f.FindHandle := THandle(nil);
311
 
end;
312
 
 
313
 
Function FileGetDate (Handle : Longint) : Longint;
314
 
 
315
 
Var Info : Stat;
316
 
 
317
 
begin
318
 
  If sys_FStat(Handle,Info)<>0 then
319
 
    Result:=-1
320
 
  else
321
 
    Result:=Info.st_mtime;
322
 
end;
323
 
 
324
 
 
325
 
Function FileSetDate (Handle,Age : Longint) : Longint;
326
 
 
327
 
begin
328
 
  // Impossible under unix from FileHandle !!
329
 
  FileSetDate:=-1;
330
 
end;
331
 
 
332
 
 
333
 
Function FileGetAttr (Const FileName : String) : Longint;
334
 
 
335
 
Var Info : Stat;
336
 
 
337
 
begin
338
 
  If sys_stat (pchar(FileName),Info)<>0 then
339
 
    Result:=-1
340
 
  Else
341
 
    Result:=UNIXToWinAttr(Pchar(FileName),Info);
342
 
end;
343
 
 
344
 
 
345
 
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
346
 
 
347
 
begin
348
 
  Result:=-1;
349
 
end;
350
 
 
351
 
 
352
 
Function DeleteFile (Const FileName : String) : Boolean;
353
 
begin
354
 
  if sys_unlink(pchar(FileName))=0 then
355
 
    DeleteFile := true
356
 
  else
357
 
    DeleteFile := false;
358
 
end;
359
 
 
360
 
Function RenameFile (Const OldName, NewName : String) : Boolean;
361
 
 
362
 
begin
363
 
  { you can directly typecast and ansistring to a pchar }
364
 
  if sys_rename(pchar(OldName),pchar(NewName))=0 then
365
 
    RenameFile := TRUE
366
 
  else
367
 
    RenameFile := FALSE;
368
 
end;
369
 
 
370
 
 
371
 
 
372
 
 
373
 
{****************************************************************************
374
 
                              Disk Functions
375
 
****************************************************************************}
376
 
 
377
 
{
378
 
  The Diskfree and Disksize functions need a file on the specified drive, since this
379
 
  is required for the statfs system call.
380
 
  These filenames are set in drivestr[0..26], and have been preset to :
381
 
   0 - '.'      (default drive - hence current dir is ok.)
382
 
   1 - '/fd0/.'  (floppy drive 1 - should be adapted to local system )
383
 
   2 - '/fd1/.'  (floppy drive 2 - should be adapted to local system )
384
 
   3 - '/'       (C: equivalent of dos is the root partition)
385
 
   4..26          (can be set by you're own applications)
386
 
  ! Use AddDisk() to Add new drives !
387
 
  They both return -1 when a failure occurs.
388
 
}
389
 
Const
390
 
  FixDriveStr : array[0..3] of pchar=(
391
 
    '.',
392
 
    '/fd0/.',
393
 
    '/fd1/.',
394
 
    '/.'
395
 
    );
396
 
var
397
 
  Drives   : byte;
398
 
  DriveStr : array[4..26] of pchar;
399
 
 
400
 
Procedure AddDisk(const path:string);
401
 
begin
402
 
  if not (DriveStr[Drives]=nil) then
403
 
   FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
404
 
  GetMem(DriveStr[Drives],length(Path)+1);
405
 
  StrPCopy(DriveStr[Drives],path);
406
 
  inc(Drives);
407
 
  if Drives>26 then
408
 
   Drives:=4;
409
 
end;
410
 
 
411
 
 
412
 
 
413
 
Function DiskFree(Drive: Byte): int64;
414
 
Begin
415
 
  DiskFree := dos.diskFree(Drive);
416
 
End;
417
 
 
418
 
 
419
 
 
420
 
Function DiskSize(Drive: Byte): int64;
421
 
Begin
422
 
  DiskSize := dos.DiskSize(Drive);
423
 
End;
424
 
 
425
 
 
426
 
 
427
 
 
428
 
Function GetCurrentDir : String;
429
 
begin
430
 
  GetDir (0,Result);
431
 
end;
432
 
 
433
 
 
434
 
Function SetCurrentDir (Const NewDir : String) : Boolean;
435
 
begin
436
 
   ChDir(NewDir);
437
 
  result := (IOResult = 0);
438
 
end;
439
 
 
440
 
 
441
 
Function CreateDir (Const NewDir : String) : Boolean;
442
 
begin
443
 
   MkDir(NewDir);
444
 
  result := (IOResult = 0);
445
 
end;
446
 
 
447
 
 
448
 
Function RemoveDir (Const Dir : String) : Boolean;
449
 
begin
450
 
   RmDir(Dir);
451
 
  result := (IOResult = 0);
452
 
end;
453
 
 
454
 
 
455
 
Function DirectoryExists(const Directory: string): Boolean;
456
 
 
457
 
var
458
 
  Info : Stat;
459
 
  l: cint;
460
 
begin
461
 
  l:=sys_Stat(pchar(Directory),Info);
462
 
  if l<>0 then
463
 
    Result:=S_ISDIR(info.st_mode)
464
 
  else
465
 
    Result := false;
466
 
end;
467
 
 
468
 
 
469
 
{****************************************************************************
470
 
                              Misc Functions
471
 
****************************************************************************}
472
 
 
473
 
procedure Beep;
474
 
begin
475
 
end;
476
 
 
477
 
 
478
 
{****************************************************************************
479
 
                              Locale Functions
480
 
****************************************************************************}
481
 
 
482
 
Procedure GetLocalTime(var SystemTime: TSystemTime);
483
 
var
484
 
 dayOfWeek: word;
485
 
begin
486
 
  dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second,SystemTime.Millisecond);
487
 
  dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, DayOfWeek);
488
 
end ;
489
 
 
490
 
 
491
 
Procedure InitAnsi;
492
 
Var
493
 
  i : longint;
494
 
begin
495
 
  {  Fill table entries 0 to 127  }
496
 
  for i := 0 to 96 do
497
 
    UpperCaseTable[i] := chr(i);
498
 
  for i := 97 to 122 do
499
 
    UpperCaseTable[i] := chr(i - 32);
500
 
  for i := 123 to 191 do
501
 
    UpperCaseTable[i] := chr(i);
502
 
  Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
503
 
 
504
 
  for i := 0 to 64 do
505
 
    LowerCaseTable[i] := chr(i);
506
 
  for i := 65 to 90 do
507
 
    LowerCaseTable[i] := chr(i + 32);
508
 
  for i := 91 to 191 do
509
 
    LowerCaseTable[i] := chr(i);
510
 
  Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
511
 
end;
512
 
 
513
 
 
514
 
Procedure InitInternational;
515
 
begin
516
 
  InitAnsi;
517
 
end;
518
 
 
519
 
function SysErrorMessage(ErrorCode: Integer): String;
520
 
 
521
 
begin
522
 
{  Result:=StrError(ErrorCode);}
523
 
end;
524
 
 
525
 
{****************************************************************************
526
 
                              OS utility functions
527
 
****************************************************************************}
528
 
 
529
 
Function GetEnvironmentVariable(Const EnvVar : String) : String;
530
 
 
531
 
begin
532
 
  Result:=Dos.Getenv(shortstring(EnvVar));
533
 
end;
534
 
 
535
 
 
536
 
{****************************************************************************
537
 
                              Initialization code
538
 
****************************************************************************}
539
 
 
540
 
Initialization
541
 
  InitExceptions;       { Initialize exceptions. OS independent }
542
 
  InitInternational;    { Initialize internationalization settings }
543
 
Finalization
544
 
  DoneExceptions;
545
 
end.
546
 
{
547
 
    $Log: sysutils.pp,v $
548
 
    Revision 1.9  2003/11/26 20:00:19  florian
549
 
      * error handling for Variants improved
550
 
 
551
 
    Revision 1.8  2003/10/25 23:43:59  hajny
552
 
      * THandle in sysutils common using System.THandle
553
 
 
554
 
    Revision 1.7  2003/10/09 20:13:19  florian
555
 
      * more type alias updates as suggested by DarekM
556
 
 
557
 
    Revision 1.6  2003/04/01 15:57:41  peter
558
 
      * made THandle platform dependent and unique type
559
 
 
560
 
    Revision 1.5  2003/03/29 15:36:58  hajny
561
 
      * DirectoryExists merged from the fixes branch
562
 
 
563
 
    Revision 1.4  2003/03/29 15:16:26  hajny
564
 
      * dummy DirectoryExists added
565
 
 
566
 
    Revision 1.3  2002/09/07 16:01:26  peter
567
 
      * old logs removed and tabs fixed
568
 
 
569
 
    Revision 1.2  2002/08/10 13:42:36  marco
570
 
     * Fixes Posix dir copied to devel branch
571
 
 
572
 
    Revision 1.1.2.5  2002/04/28 07:28:43  carl
573
 
    * some cleanup
574
 
 
575
 
    Revision 1.1.2.4  2002/03/03 08:47:37  carl
576
 
    + FindFirst / FindNext implemented
577
 
 
578
 
    Revision 1.1.2.3  2002/01/22 07:41:11  michael
579
 
    + Fixed FileSearch bug in Win32 and made FIleSearch platform independent
580
 
 
581
 
}
 
 
b'\\ No newline at end of file'