1{%MainUnit lazfileutils.pas} 2 3 4function ReadAllLinks(const Filename: string; 5 ExceptionOnError: boolean): string; 6begin 7 // not supported under Windows 8 Result:=Filename; 9end; 10 11function GetPhysicalFilename(const Filename: string; 12 OnError: TPhysicalFilenameOnError): string; 13begin 14 if OnError=pfeEmpty then ; 15 Result:=Filename; 16end; 17 18 19// ******** Start of WideString specific implementations ************ 20 21function GetCurrentDirUtf8: String; 22var 23 U: UnicodeString; 24begin 25 System.GetDir(0, U{%H-}); 26 // Need to do an explicit encode to utf8, if compiled with "-dDisableUtf8RTL" 27 Result := UTF8Encode(U); 28end; 29 30procedure GetDirUtf8(DriveNr: Byte; var Dir: String); 31var 32 U: UnicodeString; 33begin 34 {$PUSH} 35 {$IOCHECKS OFF} 36 GetDir(DriveNr, U{%H-}); 37 if IOResult <> 0 then 38 U := UnicodeString(Chr(DriveNr + Ord('A') - 1) + ':\'); 39 {$POP} 40 // Need to do an explicit encode to utf8, if compiled with "-dDisableUtf8RTL" 41 Dir := UTF8Encode(U); 42end; 43 44function FileOpenUtf8(Const FileName : string; Mode : Integer) : THandle; 45begin 46 Result := SysUtils.FileOpen(FileName, Mode); 47end; 48 49function FileCreateUTF8(Const FileName : string) : THandle; 50begin 51 Result := FileCreateUtf8(FileName, fmShareExclusive, 0); 52end; 53 54function FileCreateUTF8(Const FileName : string; Rights: Cardinal) : THandle; 55begin 56 Result := FileCreateUtf8(FileName, fmShareExclusive, Rights); 57end; 58 59function FileCreateUtf8(Const FileName : string; ShareMode: Integer; Rights: Cardinal) : THandle; 60begin 61 Result := SysUtils.FileCreate(FileName, ShareMode, Rights); 62end; 63 64function FileGetAttrUtf8(const FileName: String): Longint; 65begin 66 Result := SysUtils.FileGetAttr(FileName); 67end; 68 69function FileSetAttrUtf8(const Filename: String; Attr: longint): Longint; 70begin 71 Result := SysUtils.FileSetAttr(FileName, Attr); 72end; 73 74function FileAgeUtf8(const FileName: String): Longint; 75begin 76 Result := SysUtils.FileAge(FileName); 77end; 78 79function FileSetDateUtf8(const FileName: String; Age: Longint): Longint; 80begin 81 Result := SysUtils.FileSetDate(FileName, Age); 82end; 83 84function FileSizeUtf8(const Filename: string): int64; 85var 86 R: TSearchRec; 87begin 88 if SysUtils.FindFirst(FileName, faAnyFile, R) = 0 then 89 begin 90 Result := R.Size; 91 SysUtils.FindClose(R); 92 end 93 else 94 Result := -1; 95end; 96 97function CreateDirUtf8(const NewDir: String): Boolean; 98begin 99 Result := SysUtils.CreateDir(NewDir); 100end; 101 102function RemoveDirUtf8(const Dir: String): Boolean; 103begin 104 Result := SysUtils.RemoveDir(Dir); 105end; 106 107function DeleteFileUtf8(const FileName: String): Boolean; 108begin 109 Result := SysUtils.DeleteFile(FileName); 110end; 111 112function RenameFileUtf8(const OldName, NewName: String): Boolean; 113begin 114 Result := SysUtils.RenameFile(OldName, NewName); 115end; 116 117function SetCurrentDirUtf8(const NewDir: String): Boolean; 118begin 119 {$ifdef WinCE} 120 raise Exception.Create('[SetCurrentDirWide] The concept of the current directory doesn''t exist in Windows CE'); 121 {$else} 122 Result:=Windows.SetCurrentDirectoryW(PWidechar(UnicodeString(NewDir))); 123 {$endif} 124end; 125 126function FindFirstUtf8(const Path: string; Attr: Longint; out Rslt: TSearchRec): Longint; 127begin 128 Result := SysUtils.FindFirst(Path, Attr, Rslt); 129end; 130 131function FindNextUtf8(var Rslt: TSearchRec): Longint; 132begin 133 Result := SysUtils.FindNext(Rslt); 134end; 135 136{$IFDEF WINCE} 137// In WinCE these API calls are in Windows unit 138function SHGetFolderPathUTF8(ID : Integer) : String; 139Var 140 APath : Array[0..MAX_PATH] of WideChar; 141 WS: WideString; 142 Len: SizeInt; 143begin 144 Result := ''; 145 if SHGetSpecialFolderPath(0, APath, ID, True) then 146 begin 147 Len := StrLen(APath); 148 SetLength(WS, Len); 149 System.Move(APath[0], WS[1], Len * SizeOf(WideChar)); 150 Result := AppendPathDelim(Utf16ToUtf8(WS)); 151 end 152 else 153 Result:=''; 154end; 155{$ELSE} 156 157Type 158 PFNSHGetFolderPathW = Function(Ahwnd: HWND; Csidl: Integer; Token: THandle; Flags: DWord; Path: PWChar): HRESULT; stdcall; 159 160var 161 SHGetFolderPathW : PFNSHGetFolderPathW = Nil; 162 CFGDLLHandle : THandle = 0; 163 164Procedure InitDLL; 165Var 166 pathBuf: array[0..MAX_PATH-1] of char; 167 pathLength: Integer; 168begin 169 { Load shfolder.dll using a full path, in order to prevent spoofing (Mantis #18185) 170 Don't bother loading shell32.dll because shfolder.dll itself redirects SHGetFolderPath 171 to shell32.dll whenever possible. } 172 pathLength:=GetSystemDirectory(pathBuf, MAX_PATH); 173 if (pathLength>0) and (pathLength<MAX_PATH-14) then { 14=length('\shfolder.dll'#0) } 174 begin 175 StrLCopy(@pathBuf[pathLength],'\shfolder.dll',MAX_PATH-pathLength-1); 176 CFGDLLHandle:=LoadLibrary(pathBuf); 177 178 if (CFGDLLHandle<>0) then 179 begin 180 Pointer(ShGetFolderPathW):=GetProcAddress(CFGDLLHandle,'SHGetFolderPathW'); 181 If @ShGetFolderPathW=nil then 182 begin 183 FreeLibrary(CFGDLLHandle); 184 CFGDllHandle:=0; 185 end; 186 end; 187 end; 188 If (@ShGetFolderPathW=Nil) then 189 Raise Exception.Create('Could not determine SHGetFolderPathW Function'); 190end; 191 192function SHGetFolderPathUTF8(ID : Integer) : String; 193Var 194 APath : Array[0..MAX_PATH] of WideChar; 195 WS: WideString; 196 Len: SizeInt; 197begin 198 Result := ''; 199 if (CFGDLLHandle = 0) then 200 InitDLL; 201 If (SHGetFolderPathW <> Nil) then 202 begin 203 FillChar(APath{%H-}, SizeOf(APath), #0); 204 if SHGetFolderPathW(0,ID or CSIDL_FLAG_CREATE,0,0,@APATH[0]) = S_OK then 205 begin 206 Len := StrLen(APath); 207 SetLength(WS, Len); 208 System.Move(APath[0], WS[1], Len * SizeOf(WideChar)); 209 Result := AppendPathDelim(Utf16ToUtf8(WS)); 210 end; 211 end 212 else 213 Result := SysToUtf8(GetWindowsSpecialDir(ID)); 214end; 215 216{$ENDIF WINCE} 217 218function DGetAppConfigDir({%H-}Global : Boolean) : String; 219begin 220 Result := ChompPathDelim(ExtractFilePath(ParamStrUtf8(0))); 221end; 222 223 224function GetAppConfigDirUtf8(Global: Boolean; Create: boolean = false): string; 225const 226 CSIDL_GLOBAL = {$IFDEF WINCE}CSIDL_WINDOWS{$ELSE}CSIDL_COMMON_APPDATA{$ENDIF WINCE}; 227 CSIDL_LOCAL = {$IFDEF WINCE}CSIDL_APPDATA{$ELSE}CSIDL_LOCAL_APPDATA{$ENDIF}; 228begin 229 If Global then 230 Result := SHGetFolderPathUTF8(CSIDL_GLOBAL) 231 else 232 Result := SHGetFolderPathUTF8(CSIDL_LOCAL); 233 If (Result <> '') then 234 begin 235 if VendorName <> '' then 236 Result := AppendPathDelim(Result + VendorName); 237 Result := AppendPathDelim(Result + ApplicationName); 238 end 239 else 240 Result := AppendPathDelim(DGetAppConfigDir(Global)); 241 if Result = '' then exit; 242 if Create and not ForceDirectoriesUtf8(Result) then 243 raise EInOutError.Create(Format(lrsUnableToCreateConfigDirectoryS,[Result])); 244end; 245 246function GetAppConfigFileUtf8(Global: Boolean; SubDir: boolean; 247 CreateDir: boolean): string; 248var 249 Dir: string; 250begin 251 Result := GetAppConfigDirUtf8(Global); 252 if SubDir then 253 Result := AppendPathDelim(Result + 'Config'); 254 Result := Result + ApplicationName + ConfigExtension; 255 if not CreateDir then exit; 256 Dir := ExtractFilePath(Result); 257 if Dir = '' then exit; 258 if not ForceDirectoriesUTF8(Dir) then 259 raise EInOutError.Create(Format(lrsUnableToCreateConfigDirectoryS,[Dir])); 260end; 261 262 263function GetShellLinkTarget(const FileName: string): string; 264{$IFnDEF WINCE} 265var 266 ShellLinkW: IShellLinkW; 267 PersistFile: IPersistFile; 268 WideFileName: WideString; 269 WidePath: array [0 .. MAX_PATH] of WideChar; 270 WinFindData: WIN32_FIND_DATAW; 271 {$ENDIF WINCE} 272begin 273 Result := FileName; 274 {$IFnDEF WINCE} 275 if FilenameExtIs(FileName, '.lnk') then 276 begin 277 if (CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, 278 IShellLinkW, ShellLinkW) = S_OK) then 279 if (ShellLinkW.QueryInterface(IPersistFile, PersistFile) = S_OK) then 280 begin 281 WideFileName := Utf8ToUtf16(FileName); 282 FillChar(WinFindData{%H-}, SizeOf(WinFindData), 0); 283 if (PersistFile.Load(POleStr(WideFileName), STGM_READ) = S_OK) then 284 begin 285 if (ShellLinkW.GetPath(WidePath, Length(WidePath), 286 @WinFindData, SLGP_UNCPRIORITY) = S_OK) then 287 begin 288 Result := Utf16toUtf8(WidePath); // implicit conversion 289 end; 290 end; 291 end; 292 end; 293 {$ENDIF WINCE} 294end; 295 296// ******** End of WideString specific implementations ************ 297 298 299function FilenameIsAbsolute(const TheFilename: string):boolean; 300begin 301 Result:=FilenameIsWinAbsolute(TheFilename); 302end; 303 304 305function ExpandFileNameUtf8(const FileName: string; {const} BaseDir: String = ''): String; 306var 307 IsAbs, StartsWithRoot, CanUseBaseDir : Boolean; 308 {$ifndef WinCE} 309 HasDrive: Boolean; 310 FnDrive, CurDrive, BaseDirDrive: Char; 311 {$endif} 312 CurDir, Fn: String; 313begin 314 //writeln('LazFileUtils.ExpandFileNameUtf8'); 315 //writeln('FileName = "',FileName,'"'); 316 //writeln('BaseDir = "',BaseDir,'"'); 317 318 Fn := FileName; 319 //if Filename uses ExtendedLengthPath scheme then it cannot be expanded 320 //AND it should not be altered by ForcePathDelims or ResolveDots 321 //See: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247%28v=vs.85%29.aspx 322 if (Length(Fn) > 3) and (Fn[1] = PathDelim) and (Fn[2] = PathDelim) and 323 (Fn[3] = '?') and (Fn[4] = PathDelim) //Do NOT use AllowDirectorySeparators here! 324 then Exit(Fn); 325 ForcePathDelims(Fn); 326 IsAbs := FileNameIsWinAbsolute(Fn); 327 if not IsAbs then 328 begin 329 StartsWithRoot := (Fn = '\') or 330 ((Length(Fn) > 1) and 331 (Fn[1] = DirectorySeparator) and 332 (Fn[2] <> DirectorySeparator)); 333 {$ifndef WinCE} 334 HasDrive := (Length(Fn) > 1) and 335 (Fn[2] = ':') and 336 (UpCase(Fn[1]) in ['A'..'Z']); 337 338 if HasDrive then 339 begin 340 FnDrive := UpCase(Fn[1]); 341 GetDirUtf8(Byte(FnDrive)-64, CurDir{%H-}); 342 CurDrive := UpCase(GetCurrentDirUtf8[1]); 343 end 344 else 345 begin 346 CurDir := GetCurrentDirUtf8; 347 FnDrive := UpCase(CurDir[1]); 348 CurDrive := FnDrive; 349 end; 350 351 //writeln('HasDrive = ',HasDrive,' Fn = ',Fn); 352 //writeln('CurDir = ',CurDir); 353 //writeln('CurDrive = ',CurDrive); 354 //writeln('FnDrive = ',FnDrive); 355 356 if (Length(BaseDir) > 1) and (UpCase(BaseDir[1]) in ['A'..'Z']) and (BaseDir[2] = ':') then 357 begin 358 BaseDirDrive := BaseDir[1] 359 end 360 else 361 begin 362 if HasDrive then 363 BaseDirDrive := CurDrive 364 else 365 BaseDirDrive := #0; 366 end; 367 368 //You cannot use BaseDir if both FileName and BaseDir includes a drive and they are not the same 369 CanUseBaseDir := ((BaseDirDrive = #0) or 370 (not HasDrive) or 371 (HasDrive and (FnDrive = BaseDirDrive))) 372 and (BaseDir <> ''); 373 374 //writeln('CanUseBaseDir = ',CanUseBaseDir); 375 376 if not HasDrive and StartsWithRoot and not CanUseBaseDir then 377 begin 378 //writeln('HasDrive and StartsWithRoot'); 379 Fn := Copy(CurDir,1,2) + Fn; 380 HasDrive := True; 381 IsAbs := True; 382 end; 383 //FileNames like C:foo, strip Driveletter + colon 384 if HasDrive and not IsAbs then Delete(Fn,1,2); 385 386 //writeln('HasDrive = ',Hasdrive,' Fn = ',Fn); 387 {$else} 388 CanUseBaseDir := True; 389 {$endif WinCE} 390 end; 391 if IsAbs then 392 begin 393 //writeln('IsAbs = True -> Exit'); 394 Result := ResolveDots(Fn); 395 end 396 else 397 begin 398 if not CanUseBaseDir or (BaseDir = '') then 399 Fn := IncludeTrailingPathDelimiter(CurDir) + Fn 400 else 401 begin 402 if (Length(Fn) > 0) and (Fn[1] = DirectorySeparator) then Delete(Fn,1,1); 403 Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn; 404 end; 405 406 Fn := ResolveDots(Fn); 407 //if BaseDir is something like 'z:foo\' or '\' then this needs to be expanded as well 408 if not FileNameIsAbsolute(Fn) then 409 Fn := ExpandFileNameUtf8(Fn, ''); 410 Result := Fn; 411 end; 412end; 413 414function FileExistsUTF8(const Filename: string): boolean; 415begin 416 Result := SysUtils.FileExists(Filename); 417end; 418 419{$If FPC_FULLVERSION < 30301} 420{ Note: temporary fix for issue #39120. 421 DirectoryIsMountPoint() fixes mount points not being detected by SysUtils.DirectoryExists() which 422 causes DirectoryExistsUTF8() to return an invalid value when applied to a mount point. This in 423 turn causes the IDE to not being able to rebuild itself when installed inside a mount point. 424 425 This patch should be removed when the minimum required FPC version contains the fixed 426 DirectoryExists() function. (will be fixed in FPC 3.2.4?) } 427function DirectoryIsMountPoint(const Directory: string): boolean; 428{$ifndef wince} 429const 430 IO_REPARSE_TAG_MOUNT_POINT = $A0000003; 431var 432 Attr: Longint; 433 Rec: TSearchRec; 434{$endif} 435begin 436{$ifndef wince} 437 Attr := FileGetAttrUTF8(Directory); 438 if (Attr <> -1) and (Attr and FILE_ATTRIBUTE_REPARSE_POINT <> 0) then 439 begin 440 FindFirstUTF8(Directory, Attr, Rec); 441 if Rec.FindHandle <> feInvalidHandle then 442 begin 443 Windows.FindClose(Rec.FindHandle); 444 Result := Rec.FindData.dwReserved0 = IO_REPARSE_TAG_MOUNT_POINT; 445 end 446 else 447 Result := False; 448 end 449 else 450{$endif} 451 Result := False; 452end; 453{$endIf} 454 455function DirectoryExistsUTF8(const Directory: string): boolean; 456begin 457 Result := SysUtils.DirectoryExists(Directory) 458 {$If FPC_FULLVERSION < 30301} 459 or DirectoryIsMountPoint(Directory) 460 {$endIf}; 461end; 462 463function FileIsExecutable(const AFilename: string): boolean; 464begin 465 Result:=FileExistsUTF8(AFilename); 466end; 467 468procedure CheckIfFileIsExecutable(const AFilename: string); 469begin 470 // TProcess does not report, if a program can not be executed 471 // to get good error messages consider the OS 472 if not FileExistsUTF8(AFilename) then begin 473 raise Exception.Create(Format(lrsFileDoesNotExist, [AFilename])); 474 end; 475 if DirPathExists(AFilename) then begin 476 raise Exception.Create(Format(lrsFileIsADirectoryAndNotAnExecutable, [ 477 AFilename])); 478 end; 479end; 480 481function FileIsSymlink(const AFilename: string): boolean; 482{$ifndef wince} 483const 484 IO_REPARSE_TAG_MOUNT_POINT = $A0000003; 485 IO_REPARSE_TAG_SYMLINK = $A000000C; 486var 487 Attr: Longint; 488 Rec: TSearchRec; 489{$endif} 490begin 491{$ifndef wince} 492 Attr := FileGetAttrUTF8(AFilename); 493 if (Attr <> -1) and (Attr and FILE_ATTRIBUTE_REPARSE_POINT <> 0) then 494 begin 495 FindFirstUTF8(AFilename, Attr, Rec); 496 if Rec.FindHandle <> feInvalidHandle then 497 begin 498 Windows.FindClose(Rec.FindHandle); 499 Result := (Rec.FindData.dwReserved0 = IO_REPARSE_TAG_SYMLINK) or (Rec.FindData.dwReserved0 = IO_REPARSE_TAG_MOUNT_POINT); 500 end 501 else 502 Result := False; 503 end 504 else 505{$endif} 506 Result := False; 507end; 508 509procedure CheckIfFileIsSymlink(const AFilename: string); 510begin 511 // to get good error messages consider the OS 512 if not FileExistsUTF8(AFilename) then begin 513 raise Exception.Create(Format(lrsFileDoesNotExist, [AFilename])); 514 end; 515 if not FileIsSymLink(AFilename) then 516 raise Exception.Create(Format(lrsIsNotASymbolicLink, [AFilename])); 517end; 518 519 520function FileIsHardLink(const AFilename: string): boolean; 521{$ifndef wince} 522var 523 H: THandle; 524 FileInfo: BY_HANDLE_FILE_INFORMATION; 525 {$endif} 526begin 527 Result := false; 528 {$ifndef wince} 529 //HardLinks are not supported in Win9x platform 530 if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then Exit; 531 H := FileOpenUtf8(aFilename, fmOpenRead); 532 if (H <> feInvalidHandle) then 533 begin 534 FillChar(FileInfo{%H-}, SizeOf(BY_HANDLE_FILE_INFORMATION),0); 535 if GetFileInformationByHandle(H, FileInfo) then 536 Result := (FileInfo.nNumberOfLinks > 1); 537 FileClose(H); 538 end; 539 {$endif} 540end; 541 542function FileIsReadable(const AFilename: string): boolean; 543begin 544 Result:=FileExistsUTF8(AFilename); 545end; 546 547function FileIsWritable(const AFilename: string): boolean; 548begin 549 Result := ((FileGetAttrUTF8(AFilename) and faReadOnly) = 0); 550end; 551 552 553function IsUNCPath(const Path: String): Boolean; 554begin 555 Result := (Length(Path) > 2) and (Path[1] in AllowDirectorySeparators) and (Path[2] in AllowDirectorySeparators); 556end; 557 558function ExtractUNCVolume(const Path: String): String; 559var 560 I, Len: Integer; 561 562 // the next function reuses Len variable 563 function NextPathDelim(const Start: Integer): Integer;// inline; 564 begin 565 Result := Start; 566 while (Result <= Len) and not (Path[Result] in AllowDirectorySeparators) do 567 inc(Result); 568 end; 569 570begin 571 if not IsUNCPath(Path) then 572 Exit(''); 573 I := 3; 574 Len := Length(Path); 575 if Path[I] = '?' then 576 begin 577 // Long UNC path form like: 578 // \\?\UNC\ComputerName\SharedFolder\Resource or 579 // \\?\C:\Directory 580 inc(I); 581 if not (Path[I] in AllowDirectorySeparators) then 582 Exit(''); 583 if CompareText(Copy(Path, I+1, 3), 'UNC') = 0 then 584 begin 585 inc(I, 4); 586 if I < Len then 587 I := NextPathDelim(I + 1); 588 if I < Len then 589 I := NextPathDelim(I + 1); 590 end; 591 end 592 else 593 begin 594 I := NextPathDelim(I); 595 if I < Len then 596 I := NextPathDelim(I + 1); 597 end; 598 Result := Copy(Path, 1, I); 599end; 600 601function GetFileDescription(const AFilename: string): string; 602begin 603 // date + time 604 Result:=lrsModified; 605 try 606 Result:=Result+FormatDateTime('DD/MM/YYYY hh:mm', 607 FileDateToDateTime(FileAgeUTF8(AFilename))); 608 except 609 Result:=Result+'?'; 610 end; 611end; 612 613 614procedure InitLazFileUtils; 615begin 616end; 617 618procedure FinalizeLazFileUtils; 619begin 620 {$IFnDEF WINCE} 621 if CFGDLLHandle <> 0 then 622 FreeLibrary(CFGDllHandle); 623 {$ENDIF WINCE} 624end; 625