1{ 2 This file is part of the Free Pascal run time library. 3 Copyright (c) 2014 by Free Pascal development team 4 5 Sysutils unit for AmigaOS & clones 6 7 Based on Amiga 1.x version by Carl Eric Codere, and other 8 parts of the RTL 9 10 AmigaOS and MorphOS support by Karoly Balogh 11 AROS support by Marcus Sackrow 12 13 See the file COPYING.FPC, included in this distribution, 14 for details about the copyright. 15 16 This program is distributed in the hope that it will be useful, 17 but WITHOUT ANY WARRANTY; without even the implied warranty of 18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 19 20 **********************************************************************} 21 22unit sysutils; 23 24interface 25 26{$MODE objfpc} 27{$MODESWITCH OUT} 28{ force ansistrings } 29{$H+} 30{$modeswitch typehelpers} 31{$modeswitch advancedrecords} 32 33{$DEFINE OS_FILESETDATEBYNAME} 34{$DEFINE HAS_SLEEP} 35{$DEFINE HAS_OSERROR} 36{$DEFINE HAS_TEMPDIR} 37 38{OS has only 1 byte version for ExecuteProcess} 39{$define executeprocuni} 40 41{ used OS file system APIs use ansistring } 42{$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL} 43{ OS has an ansistring/single byte environment variable API } 44{$define SYSUTILS_HAS_ANSISTR_ENVVAR_IMPL} 45 46{ Include platform independent interface part } 47{$i sysutilh.inc} 48 49{ Platform dependent calls } 50 51function DeviceByIdx(Idx: Integer): string; 52function AddDisk(Const Path: string): Integer; 53function RefreshDeviceList: Integer; 54function DiskSize(Drive: AnsiString): Int64; 55function DiskFree(Drive: AnsiString): Int64; 56 57 58implementation 59 60uses 61 dos, sysconst; 62 63{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *) 64{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT} 65{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS} 66{$DEFINE FPC_FEXPAND_DIRSEP_IS_UPDIR} 67 68{ Include platform independent implementation part } 69{$i sysutils.inc} 70 71 72{ * Include system specific includes * } 73{$include execd.inc} 74{$include execf.inc} 75{$include timerd.inc} 76{$include doslibd.inc} 77{$include doslibf.inc} 78{$include utilf.inc} 79 80{ * Followings are implemented in the system unit! * } 81function PathConv(path: shortstring): shortstring; external name 'PATHCONV'; 82function PathConv(path: RawByteString): RawByteString; external name 'PATHCONVRBS'; 83procedure AddToList(var l: Pointer; h: LongInt); external name 'ADDTOLIST'; 84function RemoveFromList(var l: Pointer; h: LongInt): boolean; external name 'REMOVEFROMLIST'; 85function CheckInList(var l: Pointer; h: LongInt): pointer; external name 'CHECKINLIST'; 86 87var 88 ASYS_FileList: Pointer; external name 'ASYS_FILELIST'; 89 90 91function BADDR(bval: BPTR): Pointer; Inline; 92begin 93 {$if defined(AROS)} // deactivated for now //and (not defined(AROS_BINCOMPAT))} 94 BADDR := Pointer(bval); 95 {$else} 96 BADDR:=Pointer(bval Shl 2); 97 {$endif} 98end; 99 100function BSTR2STRING(s : Pointer): PChar; Inline; 101begin 102 {$if defined(AROS)} // deactivated for now //and (not defined(AROS_BINCOMPAT))} 103 BSTR2STRING:=PChar(s); 104 {$else} 105 BSTR2STRING:=PChar(BADDR(PtrInt(s)))+1; 106 {$endif} 107end; 108 109function BSTR2STRING(s : BPTR): PChar; Inline; 110begin 111 {$if defined(AROS)} // deactivated for now //and (not defined(AROS_BINCOMPAT))} 112 BSTR2STRING:=PChar(s); 113 {$else} 114 BSTR2STRING:=PChar(BADDR(s))+1; 115 {$endif} 116end; 117 118function AmigaFileDateToDateTime(aDate: TDateStamp; out success: boolean): TDateTime; 119var 120 tmpSecs: DWord; 121 tmpDate: TDateTime; 122 tmpTime: TDateTime; 123 clockData: TClockData; 124begin 125 with aDate do 126 tmpSecs:=(ds_Days * (24 * 60 * 60)) + (ds_Minute * 60) + (ds_Tick div TICKS_PER_SECOND); 127 128 Amiga2Date(tmpSecs,@clockData); 129{$HINT TODO: implement msec values, if possible} 130 with clockData do begin 131 success:=TryEncodeDate(year,month,mday,tmpDate) and 132 TryEncodeTime(hour,min,sec,0,tmpTime); 133 end; 134 135 result:=ComposeDateTime(tmpDate,tmpTime); 136end; 137 138function DateTimeToAmigaDateStamp(dateTime: TDateTime): TDateStamp; 139var 140 tmpSecs: DWord; 141 clockData: TClockData; 142 tmpMSec: Word; 143begin 144{$HINT TODO: implement msec values, if possible} 145 with clockData do begin 146 DecodeDate(dateTime,year,month,mday); 147 DecodeTime(dateTime,hour,min,sec,tmpMSec); 148 end; 149 150 tmpSecs:=Date2Amiga(@clockData); 151 152 with result do begin 153 ds_Days:= tmpSecs div (24 * 60 * 60); 154 ds_Minute:= (tmpSecs div 60) mod ds_Days; 155 ds_Tick:= (((tmpSecs mod 60) mod ds_Minute) mod ds_Days) * TICKS_PER_SECOND; 156 end; 157end; 158 159 160{**************************************************************************** 161 File Functions 162****************************************************************************} 163{$I-}{ Required for correct usage of these routines } 164 165 166(****** non portable routines ******) 167 168function FileOpen(const FileName: rawbytestring; Mode: Integer): THandle; 169var 170 SystemFileName: RawByteString; 171 dosResult: LongInt; 172begin 173 SystemFileName:=PathConv(ToSingleByteFileSystemEncodedFileName(FileName)); 174 {$WARNING FIX ME! To do: FileOpen Access Modes} 175 dosResult:=Open(PChar(SystemFileName),MODE_OLDFILE); 176 if dosResult=0 then 177 dosResult:=-1 178 else 179 AddToList(ASYS_fileList,dosResult); 180 181 FileOpen:=dosResult; 182end; 183 184 185function FileGetDate(Handle: THandle) : LongInt; 186var 187 tmpFIB : PFileInfoBlock; 188 tmpDateTime: TDateTime; 189 validFile: boolean; 190begin 191 validFile:=false; 192 193 if (Handle <> 0) then begin 194 new(tmpFIB); 195 if ExamineFH(BPTR(Handle),tmpFIB) then begin 196 tmpDateTime:=AmigaFileDateToDateTime(tmpFIB^.fib_Date,validFile); 197 end; 198 dispose(tmpFIB); 199 end; 200 201 if validFile then 202 result:=DateTimeToFileDate(tmpDateTime) 203 else 204 result:=-1; 205end; 206 207 208function FileSetDate(Handle: THandle; Age: LongInt) : LongInt; 209var 210 tmpDateStamp: TDateStamp; 211 tmpName: array[0..255] of char; 212begin 213 result:=0; 214 if (Handle <> 0) then begin 215 if NameFromFH(BPTR(Handle), @tmpName, 256) then begin 216 tmpDateStamp:=DateTimeToAmigaDateStamp(FileDateToDateTime(Age)); 217 if not SetFileDate(@tmpName,@tmpDateStamp) then begin 218 IoErr(); // dump the error code for now (TODO) 219 result:=-1; 220 end; 221 end; 222 end; 223end; 224 225 226function FileSetDate(const FileName: RawByteString; Age: LongInt) : LongInt; 227var 228 tmpDateStamp: TDateStamp; 229 SystemFileName: RawByteString; 230begin 231 result:=0; 232 SystemFileName:=PathConv(ToSingleByteFileSystemEncodedFileName(FileName)); 233 tmpDateStamp:=DateTimeToAmigaDateStamp(FileDateToDateTime(Age)); 234 if not SetFileDate(PChar(SystemFileName),@tmpDateStamp) then begin 235 IoErr(); // dump the error code for now (TODO) 236 result:=-1; 237 end; 238end; 239 240 241function FileCreate(const FileName: RawByteString) : THandle; 242var 243 SystemFileName: RawByteString; 244 dosResult: LongInt; 245begin 246 dosResult:=-1; 247 248 { Open file in MODDE_READWRITE, then truncate it by hand rather than 249 opening it in MODE_NEWFILE, because that returns an exclusive lock 250 so some operations might fail with it (KB) } 251 SystemFileName:=PathConv(ToSingleByteFileSystemEncodedFileName(FileName)); 252 dosResult:=Open(PChar(SystemFileName),MODE_READWRITE); 253 if dosResult = 0 then exit; 254 255 if SetFileSize(dosResult, 0, OFFSET_BEGINNING) = 0 then 256 AddToList(ASYS_fileList,dosResult) 257 else begin 258 dosClose(dosResult); 259 dosResult:=-1; 260 end; 261 262 FileCreate:=dosResult; 263end; 264 265function FileCreate(const FileName: RawByteString; Rights: integer): THandle; 266begin 267 {$WARNING FIX ME! To do: FileCreate Access Modes} 268 FileCreate:=FileCreate(FileName); 269end; 270 271function FileCreate(const FileName: RawByteString; ShareMode: integer; Rights : integer): THandle; 272begin 273 {$WARNING FIX ME! To do: FileCreate Access Modes} 274 FileCreate:=FileCreate(FileName); 275end; 276 277 278function FileRead(Handle: THandle; out Buffer; Count: LongInt): LongInt; 279begin 280 FileRead:=-1; 281 if (Count<=0) or (Handle=0) or (Handle=-1) then exit; 282 283 FileRead:=dosRead(Handle,@Buffer,Count); 284end; 285 286 287function FileWrite(Handle: THandle; const Buffer; Count: LongInt): LongInt; 288begin 289 FileWrite:=-1; 290 if (Count<=0) or (Handle=0) or (Handle=-1) then exit; 291 292 FileWrite:=dosWrite(Handle,@Buffer,Count); 293end; 294 295 296function FileSeek(Handle: THandle; FOffset, Origin: LongInt) : LongInt; 297var 298 seekMode: LongInt; 299begin 300 FileSeek:=-1; 301 if (Handle=0) or (Handle=-1) then exit; 302 303 case Origin of 304 fsFromBeginning: seekMode:=OFFSET_BEGINNING; 305 fsFromCurrent : seekMode:=OFFSET_CURRENT; 306 fsFromEnd : seekMode:=OFFSET_END; 307 end; 308 309 dosSeek(Handle, FOffset, seekMode); 310 { get the current position when FileSeek ends, which should return 311 the *NEW* position, while Amiga Seek() returns the old one } 312 FileSeek:=dosSeek(Handle, 0, OFFSET_CURRENT); 313end; 314 315function FileSeek(Handle: THandle; FOffset: Int64; Origin: Longint): Int64; 316begin 317 {$WARNING Need to add 64bit call } 318 FileSeek:=FileSeek(Handle,LongInt(FOffset),LongInt(Origin)); 319end; 320 321 322procedure FileClose(Handle: THandle); 323begin 324 if (Handle=0) or (Handle=-1) then exit; 325 326 dosClose(Handle); 327 RemoveFromList(ASYS_fileList,Handle); 328end; 329 330 331function FileTruncate(Handle: THandle; Size: Int64): Boolean; 332var 333 dosResult: LongInt; 334begin 335 FileTruncate:=False; 336 337 if Size > high (longint) then exit; 338{$WARNING Possible support for 64-bit FS to be checked!} 339 340 if (Handle=0) or (Handle=-1) then exit; 341 342 dosResult:=SetFileSize(Handle, Size, OFFSET_BEGINNING); 343 if (dosResult<0) then exit; 344 345 FileTruncate:=True; 346end; 347 348 349function DeleteFile(const FileName: RawByteString) : Boolean; 350var 351 SystemFileName: RawByteString; 352begin 353 SystemFileName:=PathConv(ToSingleByteFileSystemEncodedFileName(FileName)); 354 DeleteFile:=dosDeleteFile(PChar(SystemFileName)); 355end; 356 357 358function RenameFile(const OldName, NewName: RawByteString): Boolean; 359var 360 OldSystemFileName, NewSystemFileName: RawByteString; 361begin 362 OldSystemFileName:=PathConv(ToSingleByteFileSystemEncodedFileName(OldName)); 363 NewSystemFileName:=PathConv(ToSingleByteFileSystemEncodedFileName(NewName)); 364 RenameFile:=dosRename(PChar(OldSystemFileName), PChar(NewSystemFileName)) <> 0; 365end; 366 367 368(****** end of non portable routines ******) 369 370 371function FileAge (const FileName : RawByteString): Longint; 372var 373 tmpLock: BPTR; 374 tmpFIB : PFileInfoBlock; 375 tmpDateTime: TDateTime; 376 validFile: boolean; 377 SystemFileName: RawByteString; 378begin 379 validFile:=false; 380 SystemFileName := PathConv(ToSingleByteFileSystemEncodedFileName(FileName)); 381 tmpLock := Lock(PChar(SystemFileName), SHARED_LOCK); 382 383 if (tmpLock <> 0) then begin 384 new(tmpFIB); 385 if Examine(tmpLock,tmpFIB) <> 0 then begin 386 tmpDateTime:=AmigaFileDateToDateTime(tmpFIB^.fib_Date,validFile); 387 end; 388 Unlock(tmpLock); 389 dispose(tmpFIB); 390 end; 391 392 if validFile then 393 result:=DateTimeToFileDate(tmpDateTime) 394 else 395 result:=-1; 396end; 397 398 399function FileGetSymLinkTarget(const FileName: RawByteString; out SymLinkRec: TRawbyteSymLinkRec): Boolean; 400begin 401 Result := False; 402end; 403 404 405function FileExists (const FileName : RawByteString; FollowLink : Boolean) : Boolean; 406var 407 tmpLock: BPTR; 408 tmpFIB : PFileInfoBlock; 409 SystemFileName: RawByteString; 410begin 411 result:=false; 412 SystemFileName := PathConv(ToSingleByteFileSystemEncodedFileName(FileName)); 413 tmpLock := Lock(PChar(SystemFileName), SHARED_LOCK); 414 415 if (tmpLock <> 0) then begin 416 new(tmpFIB); 417 if (Examine(tmpLock,tmpFIB) <> 0) and (tmpFIB^.fib_DirEntryType <= 0) then 418 result:=true; 419 Unlock(tmpLock); 420 dispose(tmpFIB); 421 end; 422end; 423 424 425Function InternalFindFirst (Const Path : RawByteString; Attr : Longint; out Rslt : TAbstractSearchRec; var Name: RawByteString) : Longint; 426var 427 tmpStr: RawByteString; 428 Anchor: PAnchorPath; 429 tmpDateTime: TDateTime; 430 validDate: boolean; 431begin 432 result:=-1; { We emulate Linux/Unix behaviour, and return -1 on errors. } 433 434 tmpStr:=PathConv(ToSingleByteFileSystemEncodedFileName(Path)); 435 436 { $1e = faHidden or faSysFile or faVolumeID or faDirectory } 437 Rslt.ExcludeAttr := (not Attr) and ($1e); 438 Rslt.FindHandle := nil; 439 440 new(Anchor); 441 FillChar(Anchor^,sizeof(TAnchorPath),#0); 442 Rslt.FindHandle := Anchor; 443 444 if MatchFirst(pchar(tmpStr),Anchor)<>0 then 445 begin 446 InternalFindClose(Rslt.FindHandle); 447 exit; 448 end; 449 450 with Anchor^.ap_Info do begin 451 Name := fib_FileName; 452 SetCodePage(Name,DefaultFileSystemCodePage,false); 453 454 Rslt.Size := fib_Size; 455 Rslt.Time := DateTimeToFileDate(AmigaFileDateToDateTime(fib_Date,validDate)); 456 if not validDate then 457 begin 458 InternalFindClose(Rslt.FindHandle); 459 exit; 460 end; 461 462 { "128" is Windows "NORMALFILE" attribute. Some buggy code depend on this... :( (KB) } 463 Rslt.Attr := 128; 464 465 if fib_DirEntryType > 0 then Rslt.Attr:=Rslt.Attr or faDirectory; 466 if ((fib_Protection and FIBF_READ) <> 0) and 467 ((fib_Protection and FIBF_WRITE) = 0) then Rslt.Attr:=Rslt.Attr or faReadOnly; 468 469 result:=0; { Return zero if everything went OK } 470 end; 471end; 472 473 474Function InternalFindNext (var Rslt : TAbstractSearchRec; var Name : RawByteString) : Longint; 475var 476 Anchor: PAnchorPath; 477 validDate: boolean; 478begin 479 result:=-1; 480 481 Anchor:=PAnchorPath(Rslt.FindHandle); 482 if not assigned(Anchor) then exit; 483 if MatchNext(Anchor) <> 0 then exit; 484 485 with Anchor^.ap_Info do begin 486 Name := fib_FileName; 487 SetCodePage(Name,DefaultFileSystemCodePage,false); 488 Rslt.Size := fib_Size; 489 Rslt.Time := DateTimeToFileDate(AmigaFileDateToDateTime(fib_Date,validDate)); 490 if not validDate then exit; 491 492 { "128" is Windows "NORMALFILE" attribute. Some buggy code depend on this... :( (KB) } 493 Rslt.Attr := 128; 494 if fib_DirEntryType > 0 then Rslt.Attr:=Rslt.Attr or faDirectory; 495 if ((fib_Protection and FIBF_READ) <> 0) and 496 ((fib_Protection and FIBF_WRITE) = 0) then Rslt.Attr:=Rslt.Attr or faReadOnly; 497 498 result:=0; { Return zero if everything went OK } 499 end; 500end; 501 502 503Procedure InternalFindClose(var Handle: Pointer); 504var 505 Anchor: PAnchorPath absolute Handle; 506begin 507 if not assigned(Anchor) then 508 exit; 509 MatchEnd(Anchor); 510 Dispose(Anchor); 511 Handle:=nil; 512end; 513 514 515(****** end of non portable routines ******) 516 517Function FileGetAttr (Const FileName : RawByteString) : Longint; 518var 519 F: file; 520 attr: word; 521begin 522 Assign(F,FileName); 523 dos.GetFAttr(F,attr); 524 if DosError <> 0 then 525 FileGetAttr := -1 526 else 527 FileGetAttr := Attr; 528end; 529 530 531Function FileSetAttr (Const Filename : RawByteString; Attr: longint) : Longint; 532var 533 F: file; 534begin 535 Assign(F, FileName); 536 Dos.SetFAttr(F, Attr and $ffff); 537 FileSetAttr := DosError; 538end; 539 540 541 542{**************************************************************************** 543 Disk Functions 544****************************************************************************} 545 546{ 547 The Diskfree and Disksize functions need a file on the specified drive, since this 548 is required for the statfs system call. 549 These filenames are set in drivestr[0..26], and have been preset to : 550 0 - ':' (default drive - hence current dir is ok.) 551 1 - 'DF0:' (floppy drive 1 - should be adapted to local system ) 552 2 - 'DF1:' (floppy drive 2 - should be adapted to local system ) 553 3 - 'SYS:' (C: equivalent of dos is the SYS: partition) 554 4..26 (can be set by you're own applications) 555 ! Use AddDisk() to Add new drives ! 556 They both return -1 when a failure occurs. 557} 558var 559 DeviceList: array[0..26] of string[20]; 560 NumDevices: Integer = 0; 561 562const 563 IllegalDevices: array[0..12] of string =( 564 'PED:', 565 'PRJ:', 566 'PIPE:', // Pipes 567 'XPIPE:', // Extented Pipe 568 'CON:', // Console 569 'RAW:', // RAW: Console 570 'KCON:', // KingCON Console 571 'KRAW:', // KingCON RAW 572 'SER:', // serial Ports 573 'SER0:', 574 'SER1:', 575 'PAR:', // Parallel Porty 576 'PRT:'); // Printer 577 578function IsIllegalDevice(DeviceName: string): Boolean; 579var 580 i: Integer; 581 Str: AnsiString; 582begin 583 IsIllegalDevice := False; 584 Str := UpperCase(DeviceName); 585 for i := Low(IllegalDevices) to High(IllegalDevices) do 586 begin 587 if Str = IllegalDevices[i] then 588 begin 589 IsIllegalDevice := True; 590 Exit; 591 end; 592 end; 593end; 594 595function DeviceByIdx(Idx: Integer): string; 596begin 597 DeviceByIdx := ''; 598 if (Idx < 0) or (Idx >= NumDevices) then 599 Exit; 600 DeviceByIdx := DeviceList[Idx]; 601end; 602 603function AddDisk(const Path: string): Integer; 604begin 605 // if hit border, restart at 4 606 if NumDevices > 26 then 607 NumDevices := 4; 608 // set the device 609 DeviceList[NumDevices] := Copy(Path, 1, 20); 610 // return the Index increment for next run 611 AddDisk := NumDevices; 612 Inc(NumDevices); 613end; 614 615function RefreshDeviceList: Integer; 616var 617 List: PDosList; 618 Temp: PChar; 619 Str: string; 620begin 621 NumDevices := 0; 622 AddDisk(':'); // Index 0 623 AddDisk('DF0:'); // Index 1 624 AddDisk('DF1:'); // Index 2 625 AddDisk('SYS:'); // Index 3 626 // Lock the List 627 List := LockDosList(LDF_DEVICES or LDF_READ); 628 // Inspect the List 629 repeat 630 List := NextDosEntry(List, LDF_DEVICES); 631 if List <> nil then 632 begin 633 Temp := BSTR2STRING(List^.dol_Name); 634 Str := strpas(Temp) + ':'; 635 if not IsIllegalDevice(str) then 636 AddDisk(Str); 637 end; 638 until List = nil; 639 UnLockDosList(LDF_DEVICES or LDF_READ); 640 RefreshDeviceList := NumDevices; 641end; 642 643// New easier DiskSize() 644// 645function DiskSize(Drive: AnsiString): Int64; 646var 647 DirLock: BPTR; 648 Inf: TInfoData; 649 MyProc: PProcess; 650 OldWinPtr: Pointer; 651begin 652 DiskSize := -1; 653 // 654 MyProc := PProcess(FindTask(Nil)); 655 OldWinPtr := MyProc^.pr_WindowPtr; 656 MyProc^.pr_WindowPtr := Pointer(-1); 657 // 658 DirLock := Lock(PChar(Drive), SHARED_LOCK); 659 if DirLock <> 0 then 660 begin 661 if Info(DirLock, @Inf) <> 0 then 662 DiskSize := Int64(Inf.id_NumBlocks) * Inf.id_BytesPerBlock; 663 UnLock(DirLock); 664 end; 665 if OldWinPtr <> Pointer(-1) then 666 MyProc^.pr_WindowPtr := OldWinPtr; 667end; 668 669function DiskSize(Drive: Byte): Int64; 670begin 671 DiskSize := -1; 672 if (Drive < 0) or (Drive >= NumDevices) then 673 Exit; 674 DiskSize := DiskSize(DeviceList[Drive]); 675end; 676 677// New easier DiskFree() 678// 679function DiskFree(Drive: AnsiString): Int64; 680var 681 DirLock: BPTR; 682 Inf: TInfoData; 683 MyProc: PProcess; 684 OldWinPtr: Pointer; 685begin 686 DiskFree := -1; 687 // 688 MyProc := PProcess(FindTask(Nil)); 689 OldWinPtr := MyProc^.pr_WindowPtr; 690 MyProc^.pr_WindowPtr := Pointer(-1); 691 // 692 DirLock := Lock(PChar(Drive), SHARED_LOCK); 693 if DirLock <> 0 then 694 begin 695 if Info(DirLock, @Inf) <> 0 then 696 DiskFree := Int64(Inf.id_NumBlocks - Inf.id_NumBlocksUsed) * Inf.id_BytesPerBlock; 697 UnLock(DirLock); 698 end; 699 if OldWinPtr <> Pointer(-1) then 700 MyProc^.pr_WindowPtr := OldWinPtr; 701end; 702 703function DiskFree(Drive: Byte): Int64; 704begin 705 DiskFree := -1; 706 if (Drive < 0) or (Drive >= NumDevices) then 707 Exit; 708 DiskFree := DiskFree(DeviceList[Drive]); 709end; 710 711function DirectoryExists(const Directory: RawByteString; FollowLink : Boolean): Boolean; 712var 713 tmpLock: BPTR; 714 FIB : PFileInfoBlock; 715 SystemDirName: RawByteString; 716begin 717 result:=false; 718 if (Directory='') or (InOutRes<>0) then exit; 719 720 SystemDirName:=PathConv(ToSingleByteFileSystemEncodedFileName(Directory)); 721 tmpLock:=Lock(PChar(SystemDirName),SHARED_LOCK); 722 if tmpLock=0 then exit; 723 724 FIB:=nil; new(FIB); 725 726 if (Examine(tmpLock,FIB) <> 0) and (FIB^.fib_DirEntryType>0) then 727 result:=True; 728 729 if tmpLock<>0 then Unlock(tmpLock); 730 if assigned(FIB) then dispose(FIB); 731end; 732 733 734 735{**************************************************************************** 736 Locale Functions 737****************************************************************************} 738 739Procedure GetLocalTime(var SystemTime: TSystemTime); 740var 741 dayOfWeek: word; 742 Sec100: Word; 743begin 744 dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, Sec100); 745 SystemTime.Millisecond := Sec100 * 10; 746 dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, DayOfWeek); 747end; 748 749 750Procedure InitAnsi; 751Var 752 i : longint; 753begin 754 { Fill table entries 0 to 127 } 755 for i := 0 to 96 do 756 UpperCaseTable[i] := chr(i); 757 for i := 97 to 122 do 758 UpperCaseTable[i] := chr(i - 32); 759 for i := 123 to 191 do 760 UpperCaseTable[i] := chr(i); 761 Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT)); 762 763 for i := 0 to 64 do 764 LowerCaseTable[i] := chr(i); 765 for i := 65 to 90 do 766 LowerCaseTable[i] := chr(i + 32); 767 for i := 91 to 191 do 768 LowerCaseTable[i] := chr(i); 769 Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT)); 770end; 771 772 773Procedure InitInternational; 774begin 775 InitInternationalGeneric; 776 InitAnsi; 777end; 778 779function SysErrorMessage(ErrorCode: Integer): String; 780 781begin 782 Result:=Format(SUnknownErrorCode,[ErrorCode]); 783end; 784 785function GetLastOSError: Integer; 786begin 787 result:=-1; 788end; 789 790{**************************************************************************** 791 OS utility functions 792****************************************************************************} 793 794var 795 StrOfPaths: String; 796 797function SystemTags(const command: PChar; const tags: array of PtrUInt): LongInt; 798begin 799 SystemTags:=SystemTagList(command,@tags); 800end; 801 802function GetPathString: String; 803var 804 f : text; 805 s : string; 806begin 807 s := ''; 808 result := ''; 809 810 { Alternatively, this could use PIPE: handler on systems which 811 have this by default (not the case on classic Amiga), but then 812 the child process should be started async, which for a simple 813 Path command probably isn't worth the trouble. (KB) } 814 assign(f,'T:'+HexStr(FindTask(nil))+'_path.tmp'); 815 rewrite(f); 816 { This is a pretty ugly stunt, combining Pascal and Amiga system 817 functions, but works... } 818 SystemTags('C:Path',[SYS_Input, 0, SYS_Output, TextRec(f).Handle, TAG_END]); 819 close(f); 820 821 reset(f); 822 { skip the first line, garbage } 823 if not eof(f) then readln(f,s); 824 while not eof(f) do begin 825 readln(f,s); 826 if result = '' then 827 result := s 828 else 829 result := result + ';' + s; 830 end; 831 close(f); 832 erase(f); 833end; 834 835Function GetEnvironmentVariable(Const EnvVar : String) : String; 836begin 837 if UpCase(envvar) = 'PATH' then begin 838 if StrOfpaths = '' then StrOfPaths := GetPathString; 839 Result:=StrOfPaths; 840 end else 841 Result:=Dos.Getenv(shortstring(EnvVar)); 842end; 843 844Function GetEnvironmentVariableCount : Integer; 845 846begin 847 // Result:=FPCCountEnvVar(EnvP); 848 Result:=Dos.envCount; 849end; 850 851Function GetEnvironmentString(Index : Integer) : {$ifdef FPC_RTL_UNICODE}UnicodeString{$else}AnsiString{$endif}; 852 853begin 854 // Result:=FPCGetEnvStrFromP(Envp,Index); 855 Result:=Dos.EnvStr(Index); 856end; 857 858function ExecuteProcess (const Path: RawByteString; const ComLine: RawByteString;Flags:TExecuteFlags=[]): 859 integer; 860var 861 tmpPath, 862 convPath: RawByteString; 863 CommandLine: AnsiString; 864 tmpLock: BPTR; 865 866 E: EOSError; 867begin 868 DosError:= 0; 869 870 convPath:=PathConv(ToSingleByteFileSystemEncodedFileName(Path)); 871 tmpPath:=convPath+' '+ToSingleByteFileSystemEncodedFileName(ComLine); 872 873 { Here we must first check if the command we wish to execute } 874 { actually exists, because this is NOT handled by the } 875 { _SystemTagList call (program will abort!!) } 876 877 { Try to open with shared lock } 878 tmpLock:=Lock(PChar(convPath),SHARED_LOCK); 879 if tmpLock<>0 then 880 begin 881 { File exists - therefore unlock it } 882 Unlock(tmpLock); 883 result:=SystemTagList(PChar(tmpPath),nil); 884 { on return of -1 the shell could not be executed } 885 { probably because there was not enough memory } 886 if result = -1 then 887 DosError:=8; 888 end 889 else 890 DosError:=3; 891 892 if DosError <> 0 then begin 893 if ComLine = '' then 894 CommandLine := Path 895 else 896 CommandLine := Path + ' ' + ComLine; 897 898 E := EOSError.CreateFmt (SExecuteProcessFailed, [CommandLine, DosError]); 899 E.ErrorCode := DosError; 900 raise E; 901 end; 902end; 903 904function ExecuteProcess (const Path: RawByteString; 905 const ComLine: array of RawByteString;Flags:TExecuteFlags=[]): integer; 906var 907 CommandLine: RawByteString; 908 I: integer; 909 910begin 911 Commandline := ''; 912 for I := 0 to High (ComLine) do 913 if Pos (' ', ComLine [I]) <> 0 then 914 CommandLine := CommandLine + ' ' + '"' + ToSingleByteFileSystemEncodedFileName(ComLine [I]) + '"' 915 else 916 CommandLine := CommandLine + ' ' + ToSingleByteFileSystemEncodedFileName(Comline [I]); 917 ExecuteProcess := ExecuteProcess (Path, CommandLine); 918end; 919 920procedure Sleep(Milliseconds: cardinal); 921begin 922 // Amiga dos.library Delay() has precision of 1/50 seconds 923 DOSDelay(Milliseconds div 20); 924end; 925 926 927function GetTempDir(Global: Boolean): string; 928begin 929 if Assigned(OnGetTempDir) then 930 Result := OnGetTempDir(Global) 931 else 932 begin 933 Result := GetEnvironmentVariable('TEMP'); 934 if Result = '' Then 935 Result:=GetEnvironmentVariable('TMP'); 936 if Result = '' then 937 Result := 'T:'; // fallback. 938 end; 939 if Result <> '' then 940 Result := IncludeTrailingPathDelimiter(Result); 941end; 942 943 944{**************************************************************************** 945 Initialization code 946****************************************************************************} 947 948Initialization 949 InitExceptions; 950 InitInternational; { Initialize internationalization settings } 951 OnBeep:=Nil; { No SysBeep() on Amiga, for now. Figure out if we want 952 to use intuition.library/DisplayBeep() for this (KB) } 953 StrOfPaths:=''; 954 955 RefreshDeviceList; 956Finalization 957 FreeTerminateProcs; 958 DoneExceptions; 959end. 960