{**************************************************************************************************} { } { Project JEDI Code Library (JCL) } { } { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } { you may not use this file except in compliance with the License. You may obtain a copy of the } { License at http://www.mozilla.org/MPL/ } { } { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } { ANY KIND, either express or implied. See the License for the specific language governing rights } { and limitations under the License. } { } { The Original Code is JclNTFS.pas. } { } { The Initial Developer of the Original Code is Marcel van Brakel. Portions created by Marcel van } { Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved. } { } { Contributor(s): } { Marcel van Brakel } { Robert Marquardt (marquardt) } { Robert Rossmair (rrossmair) } { Petr Vones (pvones) } { Oliver Schneider (assarbad) } { ZENsan } { Florent Ouchet (outchy) } { } {**************************************************************************************************} { } { Contains routines to perform filesystem related tasks available only with NTFS. These are mostly } { relatively straightforward wrappers for various IOCTs related to compression, sparse files, } { reparse points, volume mount points and so forth. Note that some functions require NTFS 5 or } { higher! } { } {**************************************************************************************************} // Last modified: $Date: 2007-02-07 20:17:57 +0100 (mer., 07 févr. 2007) $ // Comments on Win9x compatibility of the functions used in this unit // These stubs exist on Windows 95B already but all of them // return ERROR_CALL_NOT_IMPLEMENTED: // BackupSeek, BackupRead, BackupWrite unit JclNTFS; {$I jcl.inc} {$I windowsonly.inc} interface uses {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} Windows, SysUtils, Classes, ActiveX, JclBase, JclWin32; // NTFS Exception type EJclNtfsError = class(EJclWin32Error); // NTFS - Compression type TFileCompressionState = (fcNoCompression, fcDefaultCompression, fcLZNT1Compression); function NtfsGetCompression(const FileName: string; var State: Short): Boolean; overload; function NtfsGetCompression(const FileName: string): TFileCompressionState; overload; function NtfsSetCompression(const FileName: string; const State: Short): Boolean; procedure NtfsSetFileCompression(const FileName: string; const State: TFileCompressionState); procedure NtfsSetDirectoryTreeCompression(const Directory: string; const State: TFileCompressionState); procedure NtfsSetDefaultFileCompression(const Directory: string; const State: TFileCompressionState); procedure NtfsSetPathCompression(const Path: string; const State: TFileCompressionState; Recursive: Boolean); // NTFS - Sparse Files type TNtfsAllocRanges = record Entries: Integer; Data: PFileAllocatedRangeBuffer; MoreData: Boolean; end; function NtfsSetSparse(const FileName: string): Boolean; function NtfsZeroDataByHandle(const Handle: THandle; const First, Last: Int64): Boolean; function NtfsZeroDataByName(const FileName: string; const First, Last: Int64): Boolean; function NtfsQueryAllocRanges(const FileName: string; Offset, Count: Int64; var Ranges: TNtfsAllocRanges): Boolean; function NtfsGetAllocRangeEntry(const Ranges: TNtfsAllocRanges; Index: Integer): TFileAllocatedRangeBuffer; function NtfsSparseStreamsSupported(const Volume: string): Boolean; function NtfsGetSparse(const FileName: string): Boolean; // NTFS - Reparse Points function NtfsDeleteReparsePoint(const FileName: string; ReparseTag: DWORD): Boolean; function NtfsSetReparsePoint(const FileName: string; var ReparseData; Size: Longword): Boolean; function NtfsGetReparsePoint(const FileName: string; var ReparseData: TReparseGuidDataBuffer): Boolean; function NtfsGetReparseTag(const Path: string; var Tag: DWORD): Boolean; function NtfsReparsePointsSupported(const Volume: string): Boolean; function NtfsFileHasReparsePoint(const Path: string): Boolean; // NTFS - Volume Mount Points function NtfsIsFolderMountPoint(const Path: string): Boolean; function NtfsMountDeviceAsDrive(const Device: string; Drive: Char): Boolean; function NtfsMountVolume(const Volume: Char; const MountPoint: string): Boolean; // NTFS - Change Journal // NTFS - Opportunistic Locks type TOpLock = (olExclusive, olReadOnly, olBatch, olFilter); function NtfsOpLockAckClosePending(Handle: THandle; Overlapped: TOverlapped): Boolean; function NtfsOpLockBreakAckNo2(Handle: THandle; Overlapped: TOverlapped): Boolean; function NtfsOpLockBreakAcknowledge(Handle: THandle; Overlapped: TOverlapped): Boolean; function NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolean; function NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean; // Junction Points function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean; function NtfsDeleteJunctionPoint(const Source: string): Boolean; function NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean; // Streams type TStreamId = (siInvalid, siStandard, siExtendedAttribute, siSecurity, siAlternate, siHardLink, siProperty, siObjectIdentifier, siReparsePoints, siSparseFile); TStreamIds = set of TStreamId; TInternalFindStreamData = record FileHandle: THandle; Context: Pointer; StreamIds: TStreamIds; end; TFindStreamData = record Internal: TInternalFindStreamData; Attributes: DWORD; StreamID: TStreamId; Name: WideString; Size: Int64; end; function NtfsFindFirstStream(const FileName: string; StreamIds: TStreamIds; var Data: TFindStreamData): Boolean; function NtfsFindNextStream(var Data: TFindStreamData): Boolean; function NtfsFindStreamClose(var Data: TFindStreamData): Boolean; // Hard links function NtfsCreateHardLink(const LinkFileName, ExistingFileName: String): Boolean; // ANSI-specific version function NtfsCreateHardLinkA(const LinkFileName, ExistingFileName: AnsiString): Boolean; // UNICODE-specific version function NtfsCreateHardLinkW(const LinkFileName, ExistingFileName: WideString): Boolean; type TNtfsHardLinkInfo = record LinkCount: Cardinal; case Integer of 0: ( FileIndexHigh: Cardinal; FileIndexLow: Cardinal); 1: ( FileIndex: Int64); end; function NtfsGetHardLinkInfo(const FileName: string; var Info: TNtfsHardLinkInfo): Boolean; function NtfsFindHardLinks(const Path: string; const FileIndexHigh, FileIndexLow: Cardinal; const List: TStrings): Boolean; function NtfsDeleteHardLinks(const FileName: string): Boolean; // NTFS File summary type EJclFileSummaryError = class(EJclError); TJclFileSummaryAccess = (fsaRead, fsaWrite, fsaReadWrite); TJclFileSummaryShare = (fssDenyNone, fssDenyRead, fssDenyWrite, fssDenyAll); TJclFileSummaryPropSetCallback = function(const FMTID: TGUID): Boolean of object; TJclFileSummaryPropCallback = function(const Name: WideString; ID: TPropID; Vt: TVarType): Boolean of object; TJclFileSummary = class; TJclFilePropertySet = class private FPropertyStorage: IPropertyStorage; public constructor Create(APropertyStorage: IPropertyStorage); destructor Destroy; override; class function GetFMTID: TGUID; virtual; function GetProperty(ID: TPropID): TPropVariant; overload; function GetProperty(const Name: WideString): TPropVariant; overload; procedure SetProperty(ID: TPropID; const Value: TPropVariant); overload; procedure SetProperty(const Name: WideString; const Value: TPropVariant; AllocationBase: TPropID = PID_FIRST_USABLE); overload; procedure DeleteProperty(ID: TPropID); overload; procedure DeleteProperty(const Name: WideString); overload; function EnumProperties(Proc: TJclFileSummaryPropCallback): Boolean; // casted properties // Type of ID changed to Integer to be compatible with indexed properties // VT_LPWSTR function GetWideStringProperty(const ID: Integer): WideString; procedure SetWideStringProperty(const ID: Integer; const Value: WideString); // VT_LPSTR function GetAnsiStringProperty(const ID: Integer): AnsiString; procedure SetAnsiStringProperty(const ID: Integer; const Value: AnsiString); // VT_I4 function GetIntegerProperty(const ID: Integer): Integer; procedure SetIntegerProperty(const ID: Integer; const Value: Integer); // VT_UI4 function GetCardinalProperty(const ID: Integer): Cardinal; procedure SetCardinalProperty(const ID: Integer; const Value: Cardinal); // VT_FILETIME function GetFileTimeProperty(const ID: Integer): TFileTime; procedure SetFileTimeProperty(const ID: Integer; const Value: TFileTime); // VT_CF function GetClipDataProperty(const ID: Integer): PClipData; procedure SetClipDataProperty(const ID: Integer; const Value: PClipData); // VT_BOOL function GetBooleanProperty(const ID: Integer): Boolean; procedure SetBooleanProperty(const ID: Integer; const Value: Boolean); // VT_VARIANT | VT_VECTOR function GetTCAPROPVARIANTProperty(const ID: Integer): TCAPROPVARIANT; procedure SetTCAPROPVARIANTProperty(const ID: Integer; const Value: TCAPROPVARIANT); // // VT_LPSTR | VT_VECTOR function GetTCALPSTRProperty(const ID: Integer): TCALPSTR; procedure SetTCALPSTRProperty(const ID: Integer; const Value: TCALPSTR); // VT_UI2 function GetWordProperty(const ID: Integer): Word; procedure SetWordProperty(const ID: Integer; const Value: Word); // VT_BSTR function GetBSTRProperty(const ID: Integer): WideString; procedure SetBSTRProperty(const ID: Integer; const Value: WideString); // property names function GetPropertyName(ID: TPropID): WideString; procedure SetPropertyName(ID: TPropID; const Name: WideString); procedure DeletePropertyName(ID: TPropID); end; TJclFilePropertySetClass = class of TJclFilePropertySet; TJclFileSummary = class private FFileName: WideString; FAccessMode: TJclFileSummaryAccess; FShareMode: TJclFileSummaryShare; FStorage: IPropertySetStorage; public constructor Create(AFileName: WideString; AAccessMode: TJclFileSummaryAccess; AShareMode: TJclFileSummaryShare; AsDocument: Boolean = False; ACreate: Boolean = False); destructor Destroy; override; function CreatePropertySet(AClass: TJclFilePropertySetClass; ResetExisting: Boolean): TJclFilePropertySet; procedure GetPropertySet(AClass: TJclFilePropertySetClass; out Instance); overload; procedure GetPropertySet(const FMTID: TGUID; out Instance); overload; function GetPropertySet(const FMTID: TGUID): IPropertyStorage; overload; procedure DeletePropertySet(const FMTID: TGUID); overload; procedure DeletePropertySet(AClass: TJclFilePropertySetClass); overload; function EnumPropertySet(Proc: TJclFileSummaryPropSetCallback): Boolean; property FileName: WideString read FFileName; property AccessMode: TJclFileSummaryAccess read FAccessMode; property ShareMode: TJclFileSummaryShare read FShareMode; end; TJclFileSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; property Title: AnsiString index PIDSI_TITLE read GetAnsiStringProperty write SetAnsiStringProperty; property Subject: AnsiString index PIDSI_SUBJECT read GetAnsiStringProperty write SetAnsiStringProperty; property Author: AnsiString index PIDSI_AUTHOR read GetAnsiStringProperty write SetAnsiStringProperty; property KeyWords: AnsiString index PIDSI_KEYWORDS read GetAnsiStringProperty write SetAnsiStringProperty; property Comments: AnsiString index PIDSI_COMMENTS read GetAnsiStringProperty write SetAnsiStringProperty; property Template: AnsiString index PIDSI_TEMPLATE read GetAnsiStringProperty write SetAnsiStringProperty; property LastAuthor: AnsiString index PIDSI_LASTAUTHOR read GetAnsiStringProperty write SetAnsiStringProperty; property RevNumber: AnsiString index PIDSI_REVNUMBER read GetAnsiStringProperty write SetAnsiStringProperty; property EditTime: TFileTime index PIDSI_EDITTIME read GetFileTimeProperty write SetFileTimeProperty; property LastPrintedTime: TFileTime index PIDSI_LASTPRINTED read GetFileTimeProperty write SetFileTimeProperty; property CreationTime: TFileTime index PIDSI_CREATE_DTM read GetFileTimeProperty write SetFileTimeProperty; property LastSaveTime: TFileTime index PIDSI_LASTSAVE_DTM read GetFileTimeProperty write SetFileTimeProperty; property PageCount: Integer index PIDSI_PAGECOUNT read GetIntegerProperty write SetIntegerProperty; property WordCount: Integer index PIDSI_WORDCOUNT read GetIntegerProperty write SetIntegerProperty; property CharCount: Integer index PIDSI_CHARCOUNT read GetIntegerProperty write SetIntegerProperty; property Thumnail: PClipData index PIDSI_THUMBNAIL read GetClipDataProperty write SetClipDataProperty; property AppName: AnsiString index PIDSI_APPNAME read GetAnsiStringProperty write SetAnsiStringProperty; property Security: Integer index PIDSI_DOC_SECURITY read GetIntegerProperty write SetIntegerProperty; end; TJclDocSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; property Category: AnsiString index PIDDSI_CATEGORY read GetAnsiStringProperty write SetAnsiStringProperty; property PresFormat: AnsiString index PIDDSI_PRESFORMAT read GetAnsiStringProperty write SetAnsiStringProperty; property ByteCount: Integer index PIDDSI_BYTECOUNT read GetIntegerProperty write SetIntegerProperty; property LineCount: Integer index PIDDSI_LINECOUNT read GetIntegerProperty write SetIntegerProperty; property ParCount: Integer index PIDDSI_PARCOUNT read GetIntegerProperty write SetIntegerProperty; property SlideCount: Integer index PIDDSI_SLIDECOUNT read GetIntegerProperty write SetIntegerProperty; property NoteCount: Integer index PIDDSI_NOTECOUNT read GetIntegerProperty write SetIntegerProperty; property HiddenCount: Integer index PIDDSI_HIDDENCOUNT read GetIntegerProperty write SetIntegerProperty; property MMClipCount: Integer index PIDDSI_MMCLIPCOUNT read GetIntegerProperty write SetIntegerProperty; property Scale: Boolean index PIDDSI_SCALE read GetBooleanProperty write SetBooleanProperty; property HeadingPair: TCAPROPVARIANT index PIDDSI_HEADINGPAIR read GetTCAPROPVARIANTProperty write SetTCAPROPVARIANTProperty; property DocParts: TCALPSTR index PIDDSI_DOCPARTS read GetTCALPSTRProperty write SetTCALPSTRProperty; property Manager: AnsiString index PIDDSI_MANAGER read GetAnsiStringProperty write SetAnsiStringProperty; property Company: AnsiString index PIDDSI_COMPANY read GetAnsiStringProperty write SetAnsiStringProperty; property LinksDirty: Boolean index PIDDSI_LINKSDIRTY read GetBooleanProperty write SetBooleanProperty; end; TJclMediaFileSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; property Editor: WideString index PIDMSI_EDITOR read GetWideStringProperty write SetWideStringProperty; property Supplier: WideString index PIDMSI_SUPPLIER read GetWideStringProperty write SetWideStringProperty; property Source: WideString index PIDMSI_SOURCE read GetWideStringProperty write SetWideStringProperty; property SequenceNo: WideString index PIDMSI_SEQUENCE_NO read GetWideStringProperty write SetWideStringProperty; property Project: WideString index PIDMSI_PROJECT read GetWideStringProperty write SetWideStringProperty; property Status: Cardinal index PIDMSI_STATUS read GetCardinalProperty write SetCardinalProperty; property Owner: WideString index PIDMSI_OWNER read GetWideStringProperty write SetWideStringProperty; property Rating: WideString index PIDMSI_RATING read GetWideStringProperty write SetWideStringProperty; property Production: TFileTime index PIDMSI_PRODUCTION read GetFileTimeProperty write SetFileTimeProperty; property Copyright: WideString index PIDMSI_COPYRIGHT read GetWideStringProperty write SetWideStringProperty; end; TJclMSISummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; property Version: Integer index PID_MSIVERSION read GetIntegerProperty write SetIntegerProperty; // integer, Installer version number (major*100+minor) property Source: Integer index PID_MSISOURCE read GetIntegerProperty write SetIntegerProperty; // integer, type of file image, short/long, media/tree property Restrict: Integer index PID_MSIRESTRICT read GetIntegerProperty write SetIntegerProperty; // integer, transform restrictions end; TJclShellSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_FINDDATA = 0; PID_NETRESOURCE = 1; PID_DESCRIPTIONID = 2; PID_WHICHFOLDER = 3; PID_NETWORKLOCATION = 4; PID_COMPUTERNAME = 5;} end; TJclStorageSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; end; TJclImageSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; end; TJclDisplacedSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_FINDDATA = 0; PID_NETRESOURCE = 1; PID_DESCRIPTIONID = 2; PID_WHICHFOLDER = 3; PID_NETWORKLOCATION = 4; PID_COMPUTERNAME = 5;} end; TJclBriefCaseSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_SYNC_COPY_IN = 2;} end; TJclMiscSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_MISC_STATUS = 2; PID_MISC_ACCESSCOUNT = 3; PID_MISC_OWNER = 4; PID_HTMLINFOTIPFILE = 5; PID_MISC_PICS = 6;} end; TJclWebViewSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_DISPLAY_PROPERTIES = 0; PID_INTROTEXT = 1;} end; TJclMusicSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PIDSI_ARTIST = 2; PIDSI_SONGTITLE = 3; PIDSI_ALBUM = 4; PIDSI_YEAR = 5; PIDSI_COMMENT = 6; PIDSI_TRACK = 7; PIDSI_GENRE = 11; PIDSI_LYRICS = 12;} end; TJclDRMSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PIDDRSI_PROTECTED = 2; PIDDRSI_DESCRIPTION = 3; PIDDRSI_PLAYCOUNT = 4; PIDDRSI_PLAYSTARTS = 5; PIDDRSI_PLAYEXPIRES = 6;} end; TJclVideoSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; property StreamName: WideString index PIDVSI_STREAM_NAME read GetWideStringProperty write SetWideStringProperty; // "StreamName", VT_LPWSTR property Width: Cardinal index PIDVSI_FRAME_WIDTH read GetCardinalProperty write SetCardinalProperty; // "FrameWidth", VT_UI4 property Height: Cardinal index PIDVSI_FRAME_HEIGHT read GetCardinalProperty write SetCardinalProperty; // "FrameHeight", VT_UI4 property TimeLength: Cardinal index PIDVSI_TIMELENGTH read GetCardinalProperty write SetCardinalProperty; // "TimeLength", VT_UI4, milliseconds property FrameCount: Cardinal index PIDVSI_FRAME_COUNT read GetCardinalProperty write SetCardinalProperty; // "FrameCount". VT_UI4 property FrameRate: Cardinal index PIDVSI_FRAME_RATE read GetCardinalProperty write SetCardinalProperty; // "FrameRate", VT_UI4, frames/millisecond property DataRate: Cardinal index PIDVSI_DATA_RATE read GetCardinalProperty write SetCardinalProperty; // "DataRate", VT_UI4, bytes/second property SampleSize: Cardinal index PIDVSI_SAMPLE_SIZE read GetCardinalProperty write SetCardinalProperty; // "SampleSize", VT_UI4 property Compression: WideString index PIDVSI_COMPRESSION read GetWideStringProperty write SetWideStringProperty; // "Compression", VT_LPWSTR property StreamNumber: Word index PIDVSI_STREAM_NUMBER read GetWordProperty write SetWordProperty; // "StreamNumber", VT_UI2} end; TJclAudioSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; property Format: WideString index PIDASI_FORMAT read GetBSTRProperty write SetBSTRProperty; // VT_BSTR property TimeLength: Cardinal index PIDASI_TIMELENGTH read GetCardinalProperty write SetCardinalProperty; // VT_UI4, milliseconds property AverageDataRate: Cardinal index PIDASI_AVG_DATA_RATE read GetCardinalProperty write SetCardinalProperty; // VT_UI4, Hz property SampleRate: Cardinal index PIDASI_SAMPLE_RATE read GetCardinalProperty write SetCardinalProperty; // VT_UI4, bits property SampleSize: Cardinal index PIDASI_SAMPLE_SIZE read GetCardinalProperty write SetCardinalProperty; // VT_UI4, bits property ChannelCount: Cardinal index PIDASI_CHANNEL_COUNT read GetCardinalProperty write SetCardinalProperty; // VT_UI4 property StreamNumber: Word index PIDASI_STREAM_NUMBER read GetWordProperty write SetWordProperty; // VT_UI2 property StreamName: WideString index PIDASI_STREAM_NAME read GetWideStringProperty write SetWideStringProperty; // VT_LPWSTR property Compression: WideString index PIDASI_COMPRESSION read GetWideStringProperty write SetWideStringProperty; // VT_LPWSTR} end; TJclControlPanelSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_CONTROLPANEL_CATEGORY = 2;} end; TJclVolumeSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_VOLUME_FREE = 2; PID_VOLUME_CAPACITY = 3; PID_VOLUME_FILESYSTEM = 4;} end; TJclShareSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_SHARE_CSC_STATUS = 2;} end; TJclLinkSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_LINK_TARGET = 2;} end; TJclQuerySummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {PID_QUERY_RANK = 2;} end; TJclImageInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {FMTID_ImageInformation} end; TJclJpegSummaryInformation = class(TJclFilePropertySet) public class function GetFMTID: TGUID; override; {FMTID_JpegAppHeaders} end; {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: https://jcl.svn.sourceforge.net:443/svnroot/jcl/tags/JCL-1.100-Build2646/jcl/source/windows/JclNTFS.pas $'; Revision: '$Revision: 1914 $'; Date: '$Date: 2007-02-07 20:17:57 +0100 (mer., 07 févr. 2007) $'; LogPath: 'JCL\source\windows' ); {$ENDIF UNITVERSIONING} implementation uses {$IFDEF FPC} WinSysUt, {$ENDIF FPC} ComObj, Hardlinks, JclFileUtils, JclSysInfo, JclResources, JclSecurity; //=== NTFS - Compression ===================================================== // Helper consts, helper types, helper routines const CompressionFormat: array [TFileCompressionState] of Short = ( COMPRESSION_FORMAT_NONE, COMPRESSION_FORMAT_DEFAULT, COMPRESSION_FORMAT_LZNT1 ); // use IsDirectory(FileName) as array index FileFlag: array [Boolean] of DWORD = (0, FILE_FLAG_BACKUP_SEMANTICS); type TStackFrame = packed record CallersEBP: DWord; CallerAddress: DWord; end; EJclInvalidArgument = class(EJclError); {$STACKFRAMES OFF} function CallersCallerAddress: Pointer; asm MOV EAX, [EBP] MOV EAX, TStackFrame([EAX]).CallerAddress end; {$STACKFRAMES ON} procedure ValidateArgument(Condition: Boolean; const Routine: string; const Argument: string); begin if not Condition then raise EJclInvalidArgument.CreateResFmt(@RsInvalidArgument, [Routine, Argument]) at CallersCallerAddress; end; {$IFNDEF STACKFRAMES_ON} {$STACKFRAMES OFF} {$ENDIF ~STACKFRAMES_ON} function SetCompression(const FileName: string; const State: Short; FileFlag: DWORD): Boolean; var Handle: THandle; BytesReturned: DWORD; Buffer: Short; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, FileFlag, 0); if Handle <> INVALID_HANDLE_VALUE then try Buffer := State; Result := DeviceIoControl(Handle, FSCTL_SET_COMPRESSION, @Buffer, SizeOf(Short), nil, 0, BytesReturned, nil); finally CloseHandle(Handle); end end; function SetPathCompression(Dir: string; const Mask: string; const State: Short; const SetDefault, Recursive: Boolean): Boolean; var FileName: string; SearchRec: TSearchRec; R: Integer; begin if SetDefault then Result := SetCompression(Dir, State, FILE_FLAG_BACKUP_SEMANTICS) else Result := True; if Result then begin Dir := PathAddSeparator(Dir); if FindFirst(Dir + Mask, faAnyFile, SearchRec) = 0 then try repeat if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin FileName := Dir + SearchRec.Name; if (SearchRec.Attr and faDirectory) = 0 then Result := SetCompression(FileName, State, 0) else if Recursive then Result := SetPathCompression(FileName, Mask, State, SetDefault, True); if not Result then Exit; end; R := FindNext(SearchRec); until R <> 0; Result := (R = ERROR_NO_MORE_FILES); finally SysUtils.FindClose(SearchRec); end; end; end; function NtfsGetCompression(const FileName: string; var State: Short): Boolean; var Handle: THandle; BytesReturned: DWORD; begin Result := False; Handle := CreateFile(PChar(FileName), 0, 0, nil, OPEN_EXISTING, FileFlag[IsDirectory(FileName)], 0); if Handle <> INVALID_HANDLE_VALUE then try Result := DeviceIoControl(Handle, FSCTL_GET_COMPRESSION, nil, 0, @State, SizeOf(Short), BytesReturned, nil); finally CloseHandle(Handle); end; end; function NtfsGetCompression(const FileName: string): TFileCompressionState; var State: Short; begin if not NtfsGetCompression(FileName, State) then RaiseLastOSError; case State of COMPRESSION_FORMAT_NONE: Result := fcNoCompression; COMPRESSION_FORMAT_LZNT1: Result := fcLZNT1Compression; else // (rom) very dubious. Assert(False, 'TFileCompressionState requires expansion'); Result := TFileCompressionState(State); end; end; function NtfsSetCompression(const FileName: string; const State: Short): Boolean; begin Result := SetCompression(FileName, State, FileFlag[IsDirectory(FileName)]); end; {$STACKFRAMES ON} procedure NtfsSetFileCompression(const FileName: string; const State: TFileCompressionState); begin ValidateArgument(not IsDirectory(FileName), 'NtfsSetFileCompression', 'FileName'); if not SetCompression(FileName, CompressionFormat[State], 0) then RaiseLastOSError; end; procedure NtfsSetDefaultFileCompression(const Directory: string; const State: TFileCompressionState); begin ValidateArgument(IsDirectory(Directory), 'NtfsSetDefaultFileCompression', 'Directory'); if not SetCompression(Directory, CompressionFormat[State], FILE_FLAG_BACKUP_SEMANTICS) then RaiseLastOSError; end; procedure NtfsSetDirectoryTreeCompression(const Directory: string; const State: TFileCompressionState); begin ValidateArgument(IsDirectory(Directory), 'NtfsSetDirectoryTreeCompression', 'Directory'); if not SetPathCompression(Directory, '*', CompressionFormat[State], True, True) then RaiseLastOSError; end; {$IFNDEF STACKFRAMES_ON} {$STACKFRAMES OFF} {$ENDIF ~STACKFRAMES_ON} procedure NtfsSetPathCompression(const Path: string; const State: TFileCompressionState; Recursive: Boolean); var Dir, Mask: string; SetDefault: Boolean; begin SetDefault := IsDirectory(Path); if SetDefault then begin Dir := Path; Mask := '*'; end else begin Dir := ExtractFilePath(Path); Mask := ExtractFileName(Path); if Mask = '' then Mask := '*'; end; if not SetPathCompression(Dir, Mask, CompressionFormat[State], SetDefault, Recursive) then RaiseLastOSError; end; //=== NTFS - Sparse Files ==================================================== function NtfsSetSparse(const FileName: string): Boolean; var Handle: THandle; BytesReturned: DWORD; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0); if Handle <> INVALID_HANDLE_VALUE then try Result := DeviceIoControl(Handle, FSCTL_SET_SPARSE, nil, 0, nil, 0, BytesReturned, nil); finally CloseHandle(Handle); end; end; function NtfsZeroDataByHandle(const Handle: THandle; const First, Last: Int64): Boolean; var BytesReturned: DWORD; ZeroDataInfo: TFileZeroDataInformation; Info: TByHandleFileInformation; begin Result := False; if Handle <> INVALID_HANDLE_VALUE then begin // Continue only if the file is a sparse file, this avoids the overhead // associated with an IOCTL when the file isn't even a sparse file. GetFileInformationByHandle(Handle, Info); Result := (Info.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE) <> 0; if Result then begin ZeroDataInfo.FileOffset.QuadPart := First; ZeroDataInfo.BeyondFinalZero.QuadPart := Last; Result := DeviceIoControl(Handle, FSCTL_SET_ZERO_DATA, @ZeroDataInfo, SizeOf(ZeroDataInfo), nil, 0, BytesReturned, nil); end; end; end; function NtfsZeroDataByName(const FileName: string; const First, Last: Int64): Boolean; var Handle: THandle; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0); if Handle <> INVALID_HANDLE_VALUE then try Result := NtfsZeroDataByHandle(Handle, First, Last); finally CloseHandle(Handle); end; end; function NtfsGetAllocRangeEntry(const Ranges: TNtfsAllocRanges; Index: Integer): TFileAllocatedRangeBuffer; var Offset: Longint; begin Assert((Index >= 0) and (Index < Ranges.Entries)); Offset := Longint(Ranges.Data) + Index * SizeOf(TFileAllocatedRangeBuffer); Result := PFileAllocatedRangeBuffer(Offset)^; end; function __QueryAllocRanges(const Handle: THandle; const Offset, Count: Int64; var Ranges: PFileAllocatedRangeBuffer; var MoreData: Boolean; var Size: Cardinal): Boolean; var BytesReturned: DWORD; SearchRange: TFileAllocatedRangeBuffer; BufferSize: Cardinal; begin SearchRange.FileOffset.QuadPart := Offset; SearchRange.Length.QuadPart := Count; BufferSize := 4 * 64 * SizeOf(TFileAllocatedRangeBuffer); Ranges := AllocMem(BufferSize); Result := DeviceIoControl(Handle, FSCTL_QUERY_ALLOCATED_RANGES, @SearchRange, SizeOf(SearchRange), Ranges, BufferSize, BytesReturned, nil); MoreData := GetLastError = ERROR_MORE_DATA; if MoreData then Result := True; Size := BytesReturned; if BytesReturned = 0 then begin FreeMem(Ranges); Ranges := nil; end; end; function NtfsQueryAllocRanges(const FileName: string; Offset, Count: Int64; var Ranges: TNtfsAllocRanges): Boolean; var Handle: THandle; CurrRanges: PFileAllocatedRangeBuffer; R, MoreData: Boolean; Size: Cardinal; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0); if Handle <> INVALID_HANDLE_VALUE then try R := __QueryAllocRanges(Handle, Offset, Count, CurrRanges, MoreData, Size); Ranges.MoreData := MoreData; Result := R; if R then begin Ranges.Entries := Size div SizeOf(TFileAllocatedRangeBuffer); Ranges.Data := CurrRanges; end else begin Ranges.Entries := 0; Ranges.Data := nil; end; finally CloseHandle(Handle); end; end; function NtfsSparseStreamsSupported(const Volume: string): Boolean; begin Result := fsSupportsSparseFiles in GetVolumeFileSystemFlags(Volume); end; function NtfsGetSparse(const FileName: string): Boolean; var Handle: THandle; Info: TByHandleFileInformation; begin Result := False; Handle := CreateFile(PChar(FileName), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0); if Handle <> INVALID_HANDLE_VALUE then try GetFileInformationByHandle(Handle, Info); Result := (Info.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE) <> 0; finally CloseHandle(Handle); end; end; //=== NTFS - Reparse Points ================================================== function NtfsGetReparseTag(const Path: string; var Tag: DWORD): Boolean; var SearchRec: TSearchRec; begin Result := NtfsFileHasReparsePoint(Path); if Result then begin Result := FindFirst(Path, faAnyFile, SearchRec) = 0; if Result then begin // Check if file has a reparse point Result := ((SearchRec.Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0); // If so the dwReserved0 field contains the reparse tag if Result then Tag := SearchRec.FindData.dwReserved0; FindClose(SearchRec); end; end; end; function NtfsReparsePointsSupported(const Volume: string): Boolean; begin Result := fsSupportsReparsePoints in GetVolumeFileSystemFlags(Volume); end; function NtfsFileHasReparsePoint(const Path: string): Boolean; var Attr: DWORD; begin Result := False; Attr := GetFileAttributes(PChar(Path)); if Attr <> DWORD(-1) then Result := (Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0; end; function NtfsDeleteReparsePoint(const FileName: string; ReparseTag: DWORD): Boolean; var Handle: THandle; BytesReturned: DWORD; ReparseData: TReparseGuidDataBuffer; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0); if Handle <> INVALID_HANDLE_VALUE then try FillChar(ReparseData, SizeOf(ReparseData), #0); ReparseData.ReparseTag := ReparseTag; Result := DeviceIoControl(Handle, FSCTL_DELETE_REPARSE_POINT, @ReparseData, REPARSE_GUID_DATA_BUFFER_HEADER_SIZE, nil, 0, BytesReturned, nil); finally CloseHandle(Handle); end; end; function NtfsSetReparsePoint(const FileName: string; var ReparseData; Size: Longword): Boolean; var Handle: THandle; BytesReturned: DWORD; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0); if Handle <> INVALID_HANDLE_VALUE then try Result := DeviceIoControl(Handle, FSCTL_SET_REPARSE_POINT, @ReparseData, Size, nil, 0, BytesReturned, nil); finally CloseHandle(Handle); end; end; function NtfsGetReparsePoint(const FileName: string; var ReparseData: TReparseGuidDataBuffer): Boolean; var Handle: THandle; BytesReturned: DWORD; LastError: DWORD; begin Result := False; Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0); LastError := GetLastError; if Handle <> INVALID_HANDLE_VALUE then try Result := DeviceIoControl(Handle, FSCTL_GET_REPARSE_POINT, nil, 0, @ReparseData, ReparseData.ReparseDataLength + SizeOf(ReparseData), BytesReturned, nil); if not Result then begin ReparseData.ReparseDataLength := BytesReturned; LastError := GetLastError; end; finally CloseHandle(Handle); SetLastError(LastError); end; end; //=== NTFS - Volume Mount Points ============================================= function NtfsIsFolderMountPoint(const Path: string): Boolean; var Tag: DWORD; begin Result := NtfsGetReparseTag(Path, Tag); if Result then Result := (Tag = IO_REPARSE_TAG_MOUNT_POINT); end; function NtfsMountDeviceAsDrive(const Device: string; Drive: Char): Boolean; const DDD_FLAGS = DDD_RAW_TARGET_PATH or DDD_REMOVE_DEFINITION or DDD_EXACT_MATCH_ON_REMOVE; var DriveStr: string; VolumeName: string; begin // To create a mount point we must obtain a unique volume name first. To obtain // a unique volume name the drive must exist. Therefore we must temporarily // create a symbolic link for the drive using DefineDosDevice. DriveStr := Drive + ':'; Result := DefineDosDevice(DDD_RAW_TARGET_PATH, PChar(DriveStr), PChar(Device)); if Result then begin SetLength(VolumeName, 1024); Result := RtdlGetVolumeNameForVolumeMountPoint(PChar(DriveStr + '\'), PChar(VolumeName), 1024); // Attempt to delete the symbolic link, if it fails then don't attempt to // set the mountpoint either but raise an exception instead, there's something // seriously wrong so let's try to control the damage done already :) if not DefineDosDevice(DDD_FLAGS, PChar(DriveStr), PChar(Device)) then raise EJclNtfsError.CreateRes(@RsNtfsUnableToDeleteSymbolicLink); if Result then Result := RtdlSetVolumeMountPoint(PChar(DriveStr + '\'), PChar(VolumeName)); end; end; function NtfsMountVolume(const Volume: Char; const MountPoint: string): Boolean; var VolumeName: string; VolumeStr: string; begin SetLength(VolumeName, 1024); VolumeStr := Volume + ':\'; Result := RtdlGetVolumeNameForVolumeMountPoint(PChar(VolumeStr), PChar(VolumeName), 1024); if Result then begin if not JclFileUtils.DirectoryExists(MountPoint) then JclFileUtils.ForceDirectories(MountPoint); Result := RtdlSetVolumeMountPoint(PChar(MountPoint), PChar(VolumeName)); end; end; //=== NTFS - Change Journal ================================================== //=== NTFS - Opportunistic Locks ============================================= function NtfsOpLockAckClosePending(Handle: THandle; Overlapped: TOverlapped): Boolean; var BytesReturned: Cardinal; begin Result := DeviceIoControl(Handle, FSCTL_OPBATCH_ACK_CLOSE_PENDING, nil, 0, nil, 0, BytesReturned, @Overlapped); end; function NtfsOpLockBreakAckNo2(Handle: THandle; Overlapped: TOverlapped): Boolean; var BytesReturned: Cardinal; begin Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_ACK_NO_2, nil, 0, nil, 0, BytesReturned, @Overlapped); end; function NtfsOpLockBreakAcknowledge(Handle: THandle; Overlapped: TOverlapped): Boolean; var BytesReturned: Cardinal; begin Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_ACKNOWLEDGE, nil, 0, nil, 0, BytesReturned, @Overlapped); Result := Result or (GetLastError = ERROR_IO_PENDING); end; function NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolean; var BytesReturned: Cardinal; begin Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_NOTIFY, nil, 0, nil, 0, BytesReturned, @Overlapped); end; function NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean; const IoCodes: array [TOpLock] of Cardinal = ( FSCTL_REQUEST_OPLOCK_LEVEL_1, FSCTL_REQUEST_OPLOCK_LEVEL_2, FSCTL_REQUEST_BATCH_OPLOCK, FSCTL_REQUEST_FILTER_OPLOCK); var BytesReturned: Cardinal; begin Result := DeviceIoControl(Handle, IoCodes[Kind], nil, 0, nil, 0, BytesReturned, @Overlapped); Result := Result or (GetLastError = ERROR_IO_PENDING); end; //=== Junction Points ======================================================== type TReparseDataBufferOverlay = record case Boolean of False: (Reparse: TReparseDataBuffer;); True: (Buffer: array [0..MAXIMUM_REPARSE_DATA_BUFFER_SIZE] of Char;); end; function IsReparseTagValid(Tag: DWORD): Boolean; begin Result := (Tag and (not IO_REPARSE_TAG_VALID_VALUES) = 0) and (Tag > IO_REPARSE_TAG_RESERVED_RANGE); end; function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean; var Dest: array [0..1024] of Char; // Writable copy of Destination DestW: WideString; // Unicode version of Dest FullDir: array [0..1024] of Char; FilePart: PChar; ReparseData: TReparseDataBufferOverlay; NameLength: Longword; begin Result := False; // For some reason the destination string must be prefixed with \??\ otherwise // the IOCTL will fail, ensure it's there. if Copy(Destination, 1, 3) = '\??' then StrPCopy(Dest, Destination) else begin // Make sure Destination is a directory or again, the IOCTL will fail. if (GetFullPathName(PChar(Destination), 1024, FullDir, FilePart) = 0) or (GetFileAttributes(FullDir) = DWORD(-1)) then begin SetLastError(ERROR_PATH_NOT_FOUND); Exit; end; StrPCopy(Dest, '\??\' + Destination); end; FillChar(ReparseData, SizeOf(ReparseData), #0); NameLength := StrLen(Dest) * SizeOf(WideChar); ReparseData.Reparse.ReparseTag := IO_REPARSE_TAG_MOUNT_POINT; ReparseData.Reparse.ReparseDataLength := NameLength + 12; ReparseData.Reparse.SubstituteNameLength := NameLength; ReparseData.Reparse.PrintNameOffset := NameLength + 2; // Not the most elegant way to copy an AnsiString into an Unicode buffer but // let's avoid dependencies on JclUnicode.pas (adds significant resources). DestW := WideString(Dest); Move(DestW[1], ReparseData.Reparse.PathBuffer, Length(DestW) * SizeOf(WideChar)); Result := NtfsSetReparsePoint(Source, ReparseData.Reparse, ReparseData.Reparse.ReparseDataLength + REPARSE_DATA_BUFFER_HEADER_SIZE); end; function NtfsDeleteJunctionPoint(const Source: string): Boolean; begin Result := NtfsDeleteReparsePoint(Source, IO_REPARSE_TAG_MOUNT_POINT); end; function NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean; var Handle: THandle; ReparseData: TReparseDataBufferOverlay; BytesReturned: DWORD; begin Result := False; if NtfsFileHasReparsePoint(Source) then begin Handle := CreateFile(PChar(Source), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0); if Handle <> INVALID_HANDLE_VALUE then try if DeviceIoControl(Handle, FSCTL_GET_REPARSE_POINT, nil, 0, @ReparseData, MAXIMUM_REPARSE_DATA_BUFFER_SIZE, BytesReturned, nil) {and IsReparseTagValid(ReparseData.Reparse.ReparseTag) then} then begin if BytesReturned >= ReparseData.Reparse.SubstituteNameLength + SizeOf(WideChar) then begin SetLength(Destination, (ReparseData.Reparse.SubstituteNameLength div SizeOf(WideChar)) + 1); WideCharToMultiByte(CP_THREAD_ACP, 0, ReparseData.Reparse.PathBuffer, (ReparseData.Reparse.SubstituteNameLength div SizeOf(WCHAR)) + 1, PChar(Destination), Length(Destination), nil, nil); Result := True; end; end; finally CloseHandle(Handle); end end; end; //=== Streams ================================================================ // FindStream is an internal helper routine for NtfsFindFirstStream and // NtfsFindNextStream. It uses the backup API to enumerate the streams in an // NTFS file and returns when it either finds a stream that matches the filter // specified in the Data parameter or hits EOF. Details are returned through // the Data parameter and success/failure as the Boolean result value. function FindStream(var Data: TFindStreamData): Boolean; var Header: TWin32StreamId; BytesToRead, BytesRead: DWORD; BytesToSeek: TULargeInteger; Hi, Lo: DWORD; FoundStream: Boolean; StreamName: PWideChar; begin Result := False; FoundStream := False; // We loop until we either found a stream or an error occurs. while not FoundStream do begin // Read stream header BytesToRead := DWORD(@Header.cStreamName[0]) - DWORD(@Header.dwStreamId); if not Windows.BackupRead(Data.Internal.FileHandle, (@Header), BytesToRead, BytesRead, False, True, Data.Internal.Context) then begin SetLastError(ERROR_READ_FAULT); Exit; end; if BytesRead = 0 then // EOF begin SetLastError(ERROR_NO_MORE_FILES); Exit; end; // If stream has a name then read it if Header.dwStreamNameSize > 0 then begin StreamName := HeapAlloc(GetProcessHeap, 0, Header.dwStreamNameSize + SizeOf(WCHAR)); if StreamName = nil then begin SetLastError(ERROR_OUTOFMEMORY); Exit; end; if not Windows.BackupRead(Data.Internal.FileHandle, Pointer(StreamName), Header.dwStreamNameSize, BytesRead, False, True, Data.Internal.Context) then begin HeapFree(GetProcessHeap, 0, StreamName); SetLastError(ERROR_READ_FAULT); Exit; end; StreamName[Header.dwStreamNameSize div SizeOf(WCHAR)] := WideChar(#0); end else StreamName := nil; // Did we find any of the specified streams ([] means any stream)? if (Data.Internal.StreamIds = []) or (TStreamId(Header.dwStreamId) in Data.Internal.StreamIds) then begin FoundStream := True; {$IFDEF FPC} Data.Size := Header.Size.QuadPart; {$ELSE} Data.Size := Header.Size; {$ENDIF FPC} Data.Name := StreamName; Data.Attributes := Header.dwStreamAttributes; Data.StreamId := TStreamId(Header.dwStreamId); end; // Release stream name memory if necessary if Header.dwStreamNameSize > 0 then HeapFree(GetProcessHeap, 0, StreamName); // Move past data part to beginning of next stream (or EOF) {$IFDEF FPC} BytesToSeek.QuadPart := Header.Size.QuadPart; if (Header.Size.QuadPart <> 0) and (not JclWin32.BackupSeek(Data.Internal.FileHandle, BytesToSeek.LowPart, BytesToSeek.HighPart, Lo, Hi, Data.Internal.Context)) then {$ELSE} BytesToSeek.QuadPart := Header.Size; if (Header.Size <> 0) and (not JclWin32.BackupSeek(Data.Internal.FileHandle, BytesToSeek.LowPart, BytesToSeek.HighPart, Lo, Hi, Data.Internal.Context)) then {$ENDIF FPC} begin SetLastError(ERROR_READ_FAULT); Exit; end; end; // Due to the usage of Exit, we only get here if everything succeeded Result := True; end; function NtfsFindFirstStream(const FileName: string; StreamIds: TStreamIds; var Data: TFindStreamData): Boolean; begin Result := False; // Open file for reading, note that the FILE_FLAG_BACKUP_SEMANTICS requires // the SE_BACKUP_NAME and SE_RESTORE_NAME privileges. Data.Internal.FileHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); if Data.Internal.FileHandle <> INVALID_HANDLE_VALUE then begin // Initialize private context Data.Internal.StreamIds := StreamIds; Data.Internal.Context := nil; // Call upon the Borg worker to find the next (first) stream Result := FindStream(Data); if not Result then begin // Failure, cleanup relieving the caller of having to call FindStreamClose CloseHandle(Data.Internal.FileHandle); Data.Internal.FileHandle := INVALID_HANDLE_VALUE; Data.Internal.Context := nil; if GetLastError = ERROR_NO_MORE_FILES then SetLastError(ERROR_FILE_NOT_FOUND); end; end; end; function NtfsFindNextStream(var Data: TFindStreamData): Boolean; begin Result := False; if Data.Internal.FileHandle <> INVALID_HANDLE_VALUE then Result := FindStream(Data) else SetLastError(ERROR_INVALID_HANDLE); end; function NtfsFindStreamClose(var Data: TFindStreamData): Boolean; var BytesRead: DWORD; LastError: DWORD; begin Result := Data.Internal.FileHandle <> INVALID_HANDLE_VALUE; LastError := ERROR_SUCCESS; if Result then begin // Call BackupRead one last time to signal that we're done with it Result := Windows.BackupRead(0, nil, 0, BytesRead, True, False, Data.Internal.Context); if not Result then LastError := GetLastError; CloseHandle(Data.Internal.FileHandle); Data.Internal.FileHandle := INVALID_HANDLE_VALUE; Data.Internal.Context := nil; end else LastError := ERROR_INVALID_HANDLE; SetLastError(LastError); end; //=== Hard links ============================================================= (* Implementation of CreateHardLink completely swapped to the unit Hardlink.pas As with all APIs on the NT platform this version is completely implemented in UNICODE and calling the ANSI version results in conversion of parameters and call of the underlying UNICODE version of the function. This holds both for the homegrown and the Windows API (where it exists). *) // For a description see: NtfsCreateHardLink() (* ANSI implementation of the function - calling UNICODE anyway ;-) *) function NtfsCreateHardLinkA(const LinkFileName, ExistingFileName: AnsiString): Boolean; begin // Invoke either (homegrown vs. API) function and supply NIL for security attributes Result := CreateHardLinkA(PAnsiChar(LinkFileName), PAnsiChar(ExistingFileName), nil); end; // For a description see: NtfsCreateHardLink() (* UNICODE implementation of the function - we are on NT, aren't we ;-) *) function NtfsCreateHardLinkW(const LinkFileName, ExistingFileName: WideString): Boolean; begin // Invoke either (homegrown vs. API) function and supply NIL for security attributes Result := CreateHardLinkW(PWideChar(LinkFileName), PWideChar(ExistingFileName), nil); end; // NtfsCreateHardLink // // Creates a hardlink on NT 4 and above. // Both, LinkFileName and ExistingFileName must reside on the same, NTFS formatted volume. // // LinkName: Name of the hard link to create // ExistingFileName: Fully qualified path of the file for which to create a hard link // Result: True if successfull, // False if failed. // In the latter case use GetLastError to obtain the reason of failure. // // Remark: // Hardlinks are the same as cross-referenced files were on DOS. With one exception // on NTFS they are allowed and are a feature of the filesystem, whereas on FAT // they were a feared kind of corruption of the filesystem. // // Hardlinks are no more than references (with different names, but not necessarily // in different directories) of the filesystem to exactly the same data! // // To test this you may create a hardlink to some file on your harddisk and then edit // it using Notepad (some editors do not work on the original file, but Notepad does). // The changes will appear in the "linked" and the "original" location. // // Why did I use quotes? Easy: hardlinks are references to the same data - and such // as with handles the object (i.e. data) is only destroyed after all references are // "released". To "release" a reference (i.e. a hardlink) simply delete it using // the well-known methods to delete files. Because: // // Files are hardlinks and hardlinks are files. // // The above holds for NTFS volumes (and those filesystems supporting hardlinks). // Why all references need to reside on the same volume should be clear from these // remarks. function NtfsCreateHardLink(const LinkFileName, ExistingFileName: String): Boolean; {$DEFINE ANSI} // TODO: review for possible existing compatible DEFINES in the JCL begin {$IFDEF ANSI} Result := CreateHardLinkA(PAnsiChar(LinkFileName), PAnsiChar(ExistingFileName), nil); {$ELSE} Result := CreateHardLinkW(PWideChar(LinkFileName), PWideChar(ExistingFileName)); {$ENDIF ANSI} end; function NtfsGetHardLinkInfo(const FileName: string; var Info: TNtfsHardLinkInfo): Boolean; var F: THandle; FileInfo: TByHandleFileInformation; begin Result := False; F := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0); if F <> INVALID_HANDLE_VALUE then try if GetFileInformationByHandle(F, FileInfo) then begin Info.LinkCount := FileInfo.nNumberOfLinks; Info.FileIndexHigh := FileInfo.nFileIndexHigh; Info.FileIndexLow := FileInfo.nFileIndexLow; Result := True; end; finally CloseHandle(F); end end; function NtfsFindHardLinks(const Path: string; const FileIndexHigh, FileIndexLow: Cardinal; const List: TStrings): Boolean; var SearchRec: TSearchRec; R: Integer; Info: TNtfsHardLinkInfo; begin // start the search R := FindFirst(Path + '\*.*', faAnyFile, SearchRec); Result := (R = 0); if Result then begin List.BeginUpdate; try while R = 0 do begin if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin if (SearchRec.Attr and faDirectory) = faDirectory then begin // recurse into subdirectory Result := NtfsFindHardLinks(Path + '\' + SearchRec.Name, FileIndexHigh, FileIndexLow, List); if not Result then Break; end else begin // found a file, is it a hard link? if NtfsGetHardLinkInfo(Path + '\' + SearchRec.Name, Info) then begin if (Info.FileIndexHigh = FileIndexHigh) and (Info.FileIndexLow = FileIndexLow) then List.Add(Path + '\' + SearchRec.Name); end; end; end; R := FindNext(SearchRec); end; Result := R = ERROR_NO_MORE_FILES; finally SysUtils.FindClose(SearchRec); List.EndUpdate; end; end; if R = ERROR_ACCESS_DENIED then Result := True; end; function NtfsDeleteHardLinks(const FileName: string): Boolean; var FullPathName: string; FilePart: PChar; Files: TStringList; I: Integer; Info: TNtfsHardLinkInfo; begin Result := False; // get the full pathname of the specified file SetLength(FullPathName, MAX_PATH); GetFullPathName(PChar(FileName), MAX_PATH, PChar(FullPathName), FilePart); SetLength(FullPathName, StrLen(PChar(FullPathName))); // get hard link information if NtfsGetHardLinkInfo(FullPathName, Info) then begin Files := TStringList.Create; try if Info.LinkCount > 1 then begin // find all hard links for this file if not NtfsFindHardLinks(FullPathName[1] + ':', Info.FileIndexHigh, Info.FileIndexLow, Files) then Exit; // first delete the originally specified file from the list, we don't delete that one until all hard links // are succesfully deleted so we can use it to restore them if anything goes wrong. Theoretically one could // use any of the hard links but in case the restore goes wrong, at least the specified file still exists... for I := 0 to Files.Count - 1 do begin if CompareStr(FullPathName, Files[I]) = 0 then begin Files.Delete(I); Break; end; end; // delete all found hard links I := 0; while I < Files.Count do begin if not DeleteFile(Files[I]) then Break; Inc(I); end; if I = Files.Count then begin // all hard links succesfully deleted, now delete the originally specified file. if this fails we set // I to Files.Count - 1 so that the next code block will restore all hard links we just deleted. Result := DeleteFile(FullPathName); if not Result then I := Files.Count - 1; end; if I < Files.Count then begin // not all hard links could be deleted, attempt to restore the ones that were while I >= 0 do begin // ignore result, just attempt to restore... NtfsCreateHardLink(Files[I], FullPathName); Dec(I); end; end; end else // there are no hard links, just delete the file Result := DeleteFile(FullPathName); finally Files.Free; end; end; end; //=== { TJclFileSummary } ==================================================== const AccessModes: array [TJclFileSummaryAccess] of DWORD = ( STGM_READ, STGM_WRITE, STGM_READWRITE ); ShareModes: array [TJclFileSummaryShare] of DWORD = ( STGM_SHARE_DENY_NONE, STGM_SHARE_DENY_READ, STGM_SHARE_DENY_WRITE, STGM_SHARE_EXCLUSIVE ); constructor TJclFileSummary.Create(AFileName: WideString; AAccessMode: TJclFileSummaryAccess; AShareMode: TJclFileSummaryShare; AsDocument: Boolean; ACreate: Boolean); var Format: DWORD; IntfGUID: TGUID; AIntf: IInterface; begin inherited Create; FAccessMode := AAccessMode; FShareMode := AShareMode; FFileName := AFileName; if AsDocument then Format := STGFMT_DOCFILE else if ACreate then Format := STGFMT_FILE else Format := STGFMT_ANY; IntfGUID := IPropertySetStorage; if ACreate then OleCheck(StgCreateStorageEx(PWideChar(AFileName), STGM_DIRECT or AccessModes[AAccessMode] or ShareModes[AShareMode], Format, 0, nil, nil, @IntfGUID, AIntf)) else OleCheck(StgOpenStorageEx(PWideChar(AFileName), STGM_DIRECT or AccessModes[AAccessMode] or ShareModes[AShareMode], Format, 0, nil, nil, @IntfGUID, AIntf)); FStorage := AIntf as IPropertySetStorage; end; function TJclFileSummary.CreatePropertySet(AClass: TJclFilePropertySetClass; ResetExisting: Boolean): TJclFilePropertySet; var PropertyStorage: IPropertyStorage; begin OleCheck(FStorage.Create(AClass.GetFMTID, AClass.GetFMTID, PROPSETFLAG_DEFAULT, STGM_CREATE or STGM_DIRECT or AccessModes[AccessMode] or ShareModes[ShareMode], PropertyStorage)); if Assigned(PropertyStorage) then Result := AClass.Create(PropertyStorage) else raise EJclFileSummaryError.CreateRes(@RsEUnableToCreatePropertyStorage); end; procedure TJclFileSummary.DeletePropertySet(AClass: TJclFilePropertySetClass); begin DeletePropertySet(AClass.GetFMTID); end; procedure TJclFileSummary.DeletePropertySet(const FMTID: TGUID); begin OleCheck(FStorage.Delete(FMTID)); end; destructor TJclFileSummary.Destroy; begin FStorage := nil; inherited Destroy; end; function TJclFileSummary.EnumPropertySet( Proc: TJclFileSummaryPropSetCallback): Boolean; var Enum: IEnumSTATPROPSETSTG; PropSet: STATPROPSETSTG; Returned: ULONG; Status: HRESULT; begin OleCheck(FStorage.Enum(Enum)); ZeroMemory(@PropSet, SizeOf(PropSet)); OleCheck(Enum.Reset); Status := Enum.Next(1, PropSet, @Returned); Result := True; while Result and (Status = S_OK) and (Returned = 1) do begin Result := Proc(PropSet.fmtid); if Result then Status := Enum.Next(1, PropSet, @Returned); end; end; procedure TJclFileSummary.GetPropertySet(AClass: TJclFilePropertySetClass; out Instance); var PropertyStorage: IPropertyStorage; begin TJclFilePropertySet(Instance) := nil; PropertyStorage := GetPropertySet(AClass.GetFMTID); if Assigned(PropertyStorage) then TJclFilePropertySet(Instance) := AClass.Create(PropertyStorage); end; procedure TJclFileSummary.GetPropertySet(const FMTID: TGUID; out Instance); var PropertyStorage: IPropertyStorage; begin TJclFilePropertySet(Instance) := nil; PropertyStorage := GetPropertySet(FMTID); if Assigned(PropertyStorage) then TJclFilePropertySet(Instance) := TJclFilePropertySet.Create(PropertyStorage); end; function TJclFileSummary.GetPropertySet(const FMTID: TGUID): IPropertyStorage; var Status: HRESULT; begin Status := FStorage.Open(FMTID, STGM_DIRECT or AccessModes[AccessMode] or ShareModes[ShareMode], Result); if (Status = STG_E_FILENOTFOUND) then begin if AccessMode = fsaRead then Result := nil else OleCheck(FStorage.Create(FMTID, FMTID, PROPSETFLAG_DEFAULT, STGM_CREATE or STGM_DIRECT or AccessModes[AccessMode] or ShareModes[ShareMode], Result)) end else OleCheck(Status); end; //=== { TJclFilePropertySet } ================================================ constructor TJclFilePropertySet.Create(APropertyStorage: IPropertyStorage); begin inherited Create; FPropertyStorage := APropertyStorage; end; procedure TJclFilePropertySet.DeleteProperty(const Name: WideString); var Prop: TPropSpec; begin Prop.ulKind := PRSPEC_LPWSTR; Prop.lpwstr := PWideChar(Name); OleCheck(FPropertyStorage.DeleteMultiple(1, @Prop)); end; procedure TJclFilePropertySet.DeletePropertyName(ID: TPropID); begin OleCheck(FPropertyStorage.DeletePropertyNames(1, @ID)); end; procedure TJclFilePropertySet.DeleteProperty(ID: TPropID); var Prop: TPropSpec; begin Prop.ulKind := PRSPEC_PROPID; Prop.propid := ID; OleCheck(FPropertyStorage.DeleteMultiple(1, @Prop)); end; destructor TJclFilePropertySet.Destroy; begin FPropertyStorage := nil; inherited Destroy; end; function TJclFilePropertySet.EnumProperties( Proc: TJclFileSummaryPropCallback): Boolean; var Enum: IEnumSTATPROPSTG; Status: HRESULT; Returned: ULONG; Prop: STATPROPSTG; begin OleCheck(FPropertyStorage.Enum(Enum)); ZeroMemory(@Prop, SizeOf(Prop)); OleCheck(Enum.Reset); Status := Enum.Next(1, Prop, @Returned); Result := True; while Result and (Status = S_OK) and (Returned = 1) do begin try Result := Proc(Prop.lpwstrName, Prop.propid, Prop.vt); finally if Assigned(Prop.lpwstrName) then CoTaskMemFree(Prop.lpwstrName); end; if Result then Status := Enum.Next(1, Prop, @Returned); end; end; function TJclFilePropertySet.GetAnsiStringProperty( const ID: Integer): AnsiString; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := ''; VT_LPSTR: Result := PropValue.pszVal; VT_LPWSTR: Result := PropValue.pwszVal; VT_BSTR: Result := PropValue.bstrVal; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetBooleanProperty(const ID: Integer): Boolean; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := False; VT_BOOL: Result := PropValue.bool; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetBSTRProperty(const ID: Integer): WideString; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := ''; VT_LPSTR: Result := PropValue.pszVal; VT_LPWSTR: Result := PropValue.pwszVal; VT_BSTR: Result := PropValue.bstrVal; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetCardinalProperty(const ID: Integer): Cardinal; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := 0; VT_I2: Result := PropValue.iVal; VT_I4, VT_INT: Result := PropValue.lVal; VT_I1: Result := PropValue.bVal; // no ShortInt? (cVal) VT_UI1: Result := PropValue.bVal; VT_UI2: Result := PropValue.uiVal; VT_UI4, VT_UINT: Result := PropValue.ulVal; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetClipDataProperty(const ID: Integer): PClipData; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := nil; VT_CF: Result := PropValue.pclipdata else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetFileTimeProperty(const ID: Integer): TFileTime; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: ZeroMemory(@Result, SizeOf(Result)); VT_FILETIME: Result := PropValue.filetime; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; class function TJclFilePropertySet.GetFMTID: TGUID; begin Result := GUID_NULL; end; function TJclFilePropertySet.GetIntegerProperty(const ID: Integer): Integer; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := 0; VT_I2: Result := PropValue.iVal; VT_I4, VT_INT: Result := PropValue.lVal; VT_I1: Result := PropValue.bVal; // no ShortInt? (cVal) VT_UI1: Result := PropValue.bVal; VT_UI2: Result := PropValue.uiVal; VT_UI4, VT_UINT: Result := PropValue.ulVal; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetProperty(const Name: WideString): TPropVariant; var Prop: TPropSpec; begin Prop.ulKind := PRSPEC_LPWSTR; Prop.lpwstr := PWideChar(Name); OleCheck(FPropertyStorage.ReadMultiple(1, @Prop, @Result)); end; function TJclFilePropertySet.GetProperty(ID: TPropID): TPropVariant; var Prop: TPropSpec; begin Prop.ulKind := PRSPEC_PROPID; Prop.propid := ID; OleCheck(FPropertyStorage.ReadMultiple(1, @Prop, @Result)); end; function TJclFilePropertySet.GetPropertyName(ID: TPropID): WideString; var AName: PWideChar; begin AName := nil; try OleCheck(FPropertyStorage.ReadPropertyNames(1, @ID, @AName)); Result := AName; finally if Assigned(AName) then CoTaskMemFree(AName); end; end; function TJclFilePropertySet.GetTCALPSTRProperty(const ID: Integer): TCALPSTR; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: ZeroMemory(@Result, SizeOf(Result)); VT_LPSTR or VT_VECTOR: Result := PropValue.calpstr; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetTCAPROPVARIANTProperty( const ID: Integer): TCAPROPVARIANT; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: ZeroMemory(@Result, SizeOf(Result)); VT_VARIANT or VT_VECTOR: Result := PropValue.capropvar; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetWideStringProperty( const ID: Integer): WideString; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := ''; VT_LPSTR: Result := PropValue.pszVal; VT_LPWSTR: Result := PropValue.pwszVal; VT_BSTR: Result := PropValue.bstrVal; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; function TJclFilePropertySet.GetWordProperty(const ID: Integer): Word; var PropValue: TPropVariant; begin PropValue := GetProperty(ID); case PropValue.vt of VT_EMPTY, VT_NULL: Result := 0; VT_I2: Result := PropValue.iVal; VT_I1: Result := PropValue.bVal; // no ShortInt? (cVal) VT_UI1: Result := PropValue.bVal; VT_UI2: Result := PropValue.uiVal; else raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat); end; end; procedure TJclFilePropertySet.SetAnsiStringProperty(const ID: Integer; const Value: AnsiString); var PropValue: TPropVariant; begin PropValue.vt := VT_LPSTR; PropValue.pszVal := PAnsiChar(Value); SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetBooleanProperty(const ID: Integer; const Value: Boolean); var PropValue: TPropVariant; begin PropValue.vt := VT_BOOL; PropValue.bool := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetBSTRProperty(const ID: Integer; const Value: WideString); var PropValue: TPropVariant; begin PropValue.vt := VT_BSTR; PropValue.bstrVal := PWideChar(Value); SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetCardinalProperty(const ID: Integer; const Value: Cardinal); var PropValue: TPropVariant; begin PropValue.vt := VT_UI4; PropValue.ulVal := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetClipDataProperty(const ID: Integer; const Value: PClipData); var PropValue: TPropVariant; begin PropValue.vt := VT_CF; PropValue.pclipdata := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetFileTimeProperty(const ID: Integer; const Value: TFileTime); var PropValue: TPropVariant; begin PropValue.vt := VT_FILETIME; PropValue.filetime := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetIntegerProperty(const ID, Value: Integer); var PropValue: TPropVariant; begin PropValue.vt := VT_I4; PropValue.lVal := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetProperty(const Name: WideString; const Value: TPropVariant; AllocationBase: TPropID); var Prop: TPropSpec; begin Prop.ulKind := PRSPEC_LPWSTR; Prop.lpwstr := PWideChar(Name); OleCheck(FPropertyStorage.WriteMultiple(1, @Prop, @Value, AllocationBase)); end; procedure TJclFilePropertySet.SetPropertyName(ID: TPropID; const Name: WideString); var AName: PWideChar; begin OleCheck(FPropertyStorage.WritePropertyNames(1, @ID, @AName)); end; procedure TJclFilePropertySet.SetTCALPSTRProperty(const ID: Integer; const Value: TCALPSTR); var PropValue: TPropVariant; begin PropValue.vt := VT_LPSTR or VT_VECTOR; PropValue.calpstr := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetTCAPROPVARIANTProperty(const ID: Integer; const Value: TCAPROPVARIANT); var PropValue: TPropVariant; begin PropValue.vt := VT_VARIANT or VT_VECTOR; PropValue.capropvar := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetWideStringProperty(const ID: Integer; const Value: WideString); var PropValue: TPropVariant; begin PropValue.vt := VT_LPWSTR; PropValue.pwszVal := PWideChar(Value); SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetWordProperty(const ID: Integer; const Value: Word); var PropValue: TPropVariant; begin PropValue.vt := VT_UI2; PropValue.uiVal := Value; SetProperty(ID, PropValue); end; procedure TJclFilePropertySet.SetProperty(ID: TPropID; const Value: TPropVariant); var Prop: TPropSpec; begin Prop.ulKind := PRSPEC_PROPID; Prop.propid := ID; OleCheck(FPropertyStorage.WriteMultiple(1, @Prop, @Value, PID_FIRST_USABLE)); end; //=== { TJclFileSummaryInformation } ========================================= class function TJclFileSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_SummaryInformation; end; //=== { TJclDocSummaryInformation } ========================================== class function TJclDocSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_DocumentSummaryInformation; end; //=== { TJclMediaSummaryInformation } ======================================== class function TJclMediaFileSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_MediaFileSummaryInformation end; //=== { TJclMSISummaryInformation } ========================================== class function TJclMSISummaryInformation.GetFMTID: TGUID; begin Result := FMTID_SummaryInformation; end; //=== { TJclShellSummaryInformation } ======================================== class function TJclShellSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_ShellDetails; end; //=== { TJclStorageSummaryInformation } ====================================== class function TJclStorageSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Storage; end; //=== { TJclImageSummaryInformation } ======================================== class function TJclImageSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_ImageSummaryInformation; end; //=== { TJclDisplacedSummaryInformation } ==================================== class function TJclDisplacedSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Displaced; end; //=== { TJclBriefCaseSummaryInformation } class function TJclBriefCaseSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Briefcase; end; //=== { TJclMiscSummaryInformation } ========================================= class function TJclMiscSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Misc; end; //=== { TJclWebViewSummaryInformation } ====================================== class function TJclWebViewSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_WebView; end; //=== { TJclMusicSummaryInformation } ======================================== class function TJclMusicSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_MUSIC; end; //=== { TJclDRMSummaryInformation } ========================================== class function TJclDRMSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_DRM; end; //=== { TJclVideoSummaryInformation } ======================================== class function TJclVideoSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Video; end; //=== { TJclAudioSummaryInformation } ======================================== class function TJclAudioSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Audio; end; //=== { TJclControlPanelSummaryInformation } ================================= class function TJclControlPanelSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_ControlPanel; end; //=== { TJclVolumeSummaryInformation } ======================================= class function TJclVolumeSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Volume; end; //=== { TJclShareSummaryInformation } ======================================== class function TJclShareSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Share; end; //=== { TJclLinkSummaryInformation } ========================================= class function TJclLinkSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Link; end; //=== { TJclQuerySummaryInformation } ======================================== class function TJclQuerySummaryInformation.GetFMTID: TGUID; begin Result := FMTID_Query; end; //=== { TJclImageInformation } =============================================== class function TJclImageInformation.GetFMTID: TGUID; begin Result := FMTID_ImageInformation; end; //=== { TJclJpegSummaryInformation } ========================================= class function TJclJpegSummaryInformation.GetFMTID: TGUID; begin Result := FMTID_JpegAppHeaders; end; {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); finalization UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} end.