Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
{$APPTYPE CONSOLE}
program adscreate; uses sysutils;
var
outfile: text;
i: integer;
begin
assign(outfile, 'ADSTEXT.TXT');
rewrite(outfile);
writeln(outfile, 'Test');
close(outfile);
writeln('Main file created.');
for i := 1 to 9 do
begin
assign(outfile, 'ADSTEXT.TXT:INSIDE' + IntToStr(i) + '.TXT');
rewrite(outfile);
writeln(outfile, 'Test ADS ', IntToStr(i));
close(outfile);
writeln('ADS file ', i, ' created.');
end;
readln;
end.
{$APPTYPE CONSOLE}
program adsview; uses sysutil2;
var
SR: TADSSearchRec;
begin
if ADSFindFirst('D:\BACKUP', SR) = false then
repeat
if SR.StreamName <> '' then
writeln(SR.StreamName, ' : ', SR.StreamSize);
until ADSFindNext(SR) = true;
if SR.StreamName <> '' then
writeln(SR.StreamName, ' : ', SR.StreamSize);
readln;
end.
{$APPTYPE CONSOLE}
program comptest; uses sysutils, sysutil2;
{ test compression attribute on a file }
var
outfile: text;
i: integer;
fattr: Integer;
HighWord: DWord;
begin
assign(outfile, 'COMPTEST.TXT');
rewrite(outfile);
for i := 1 to 2000 do
writeln(outfile, 'Test.');
close(outfile);
if CompressFile('COMPTEST.TXT', true) then
Writeln('File is compressed.')
else
Writeln('File compress Failed.');
readln;
fattr := FileGetAttr('COMPTEST.TXT');
if (fattr and faCompressed) = faCompressed then
writeln('File shows to be compressed.');
writeln(' Compressed size is: ',
GetCompressedFileSize('COMPTEST.TXT', HighWord), ' bytes.');
readln;
if CompressFile('COMPTEST.TXT', false) then
Writeln('File is decompressed.')
else
Writeln('file deCompress Failed.');
readln;
fattr := FileGetAttr('COMPTEST.TXT');
if (fattr and faCompressed) <> faCompressed then
writeln('File shows to be not compressed.');
writeln('Uncompressed size is: ',
GetCompressedFileSize('COMPTEST.TXT', HighWord), ' bytes.');
readln;
end.
{$APPTYPE CONSOLE}
program sparse_file; uses windows, sysutils, sysutil2;
{ creation and usage of sparse file }
var
filepath: string;
fattr: integer;
fhigh: DWord;
function sparse_write(filepath: string): boolean;
{ writes the sparse range allocation array }
var
fsbuffer: array[1..1024] of TRangeBuffer;
bytesreturned, reccnt, i: DWord;
begin
bytesreturned := sparse_query_ranges(filepath, @fsbuffer, sizeof(fsbuffer));
if bytesreturned <> -1 then
begin
writeln('Bytes Returned: ', bytesreturned);
Result := true;
end
else
begin
writeln('Error in return.');
Result := false;
end;
writeln;
reccnt := bytesreturned div Sizeof(TRangeBuffer);
for i := 1 to reccnt do
begin
writeln(i, ' File Offset: ', fsbuffer[i].fileoffsetlow);
writeln(i, ' File Length: ', fsbuffer[i].fileLengthLow);
writeln;
end;
end;
procedure write_test(var filepath: string);
var
outfile: THandle;
i, k, bufcount, byteswritten: longint;
inbuffer: packed array[1..2] of char;
begin
{ write an eligible sparse test file }
outfile := CreateFile(PChar(filepath), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_ALWAYS,
FILE_FLAG_BACKUP_SEMANTICS, 0);
if sparse_set_file(filepath) then
writeln('Sparse file set.')
else
writeln('Sparse file not set.');
for k := 1 to 20 do
begin
bufcount := 1;
for i := 1 to 10 do
begin
sparse_zero_file(filepath, bufcount, 640000);
// this function above does not set the file pointer, you must do that
SetFilePointer(outfile, 640000, nil, FILE_CURRENT);
bufcount := bufcount + 640000;
inbuffer[1] := #3;
inbuffer[2] := #2;
WriteFile(outfile, inbuffer, sizeof(inbuffer), byteswritten, nil);
inc(bufcount, 2);
end;
end;
CloseHandle(outfile);
end;
begin
filepath := 'SPARSE_TEST.DAT';
// write the sparse data file
write_test(filepath);
// test for the sparse file attribute
fattr := FileGetAttr(filepath);
if (fattr and faSparseFile) = faSparseFile then
writeln('File shows to be sparse file.')
else
writeln('File is not sparse file.');
// finally write the allocation spots and the storage size of the file
sparse_write(filepath);
writeln('File size is: ', GetCompressedFileSize(filepath, fhigh));
readln;
end.
{$APPTYPE CONSOLE}
program hardlink; uses ntfsfile;
var
oldfile, newlink: string;
begin
oldfile := 'ADSREAD.EXE';
newlink := 'TEST.EXE';
if CreateHardLink(newlink, oldfile) then
writeln('Hard link created.')
else
writeln('Hard link not created.');
readln;
end.
unit sysutil2;
{
sysutils+ = try to properly access some NTFS related disk functions
can not implement and test due to not having access to it:
1) EFS Encryption
2) Symbolic links
}
interface
const
{ new file attribute constants }
faDevice = $40; // device - not used
faNormal = $80; // normal file - implied not any other attr
faTemporary = $100; // temporary file
faSparseFile = $200; // sparse file
faReparsePoint = $400; // file with reparse point or symbolic link
faCompressed = $800; // compressed file
faOffline = $1000; // file is offline
faNotContentIndexed = $2000; // file is not content indexed
faEncrypted = $4000; // encrypted file
faVirtual = $10000; // virtual file
type
DWord = Longint;
TFileInformation = array[1..16384] of byte;
TADSSearchRec = record
StreamName: string;
StreamSize: longint;
IB: TFileInformation;
IBPos: longint;
end;
TRangeBuffer = record
FileOffsetLow: DWord;
FileOffSetHigh: DWord;
FileLengthLow: DWord;
FileLengthHigh: DWord;
end;
function ADSFindFirst(filename: string; var SR: TADSSearchRec): boolean;
function ADSFindNext(var SR: TADSSearchRec): boolean;
function CompressFile(filepath: string; state: boolean): boolean;
function GetCompressedFileSize(FileName: string; var HighFileSize: DWord): DWord;
function sparse_set_file(filepath: string): boolean;
function sparse_zero_file(filepath: string; start, range: longint): boolean;
function sparse_query_ranges(filepath: string; fsbuffer: pointer; fssize: DWord): Longint;
function CreateHardLink(newlink, currfile: string): boolean;
implementation
uses windows, d3_priv, sysutils;
const
FSCTL_SET_COMPRESSION: DWord = $9C040;
FSCTL_GET_COMPRESSION: DWord = $9003C;
FSCTL_SET_SPARSE: DWord = $900C4;
FSCTL_SET_ZERO_DATA: DWord = $980C8;
FSCTL_QUERY_ALLOCATED_RANGES: DWord = $940CF;
FileStreamInformation = 22;
COMPRESSION_FORMAT_DEFAULT = 1;
COMPRESSION_FORMAT_NONE = 0;
type
TIOStatusBlock = record
Status: DWord;
Information: DWord;
end;
TFileStreamInfo = record
NextEntry: DWord;
NameLength: DWord;
StreamSizeLow: DWord;
StreamSizeHigh: DWord;
AllocLow: DWord;
AllocHigh: DWord;
cStreamName: array[1..296] of widechar;
end;
PFileStreamInfo = ^TFileStreamInfo;
NTQProc = procedure(FileHandle: THandle; var ISB: TIOStatusBlock;
InfoBlock: TFileInformation;
InfoBlockSize: DWord; FSI: Integer); stdcall;
GCSFunc = function(FileName: PChar; var HighFileSize: DWord): DWord; stdcall;
procedure GetFileInfoBlock(FHandle: THandle; var Infoblock: TfileInformation);
{ bulk of work here - get the IO block and then return first item }
var
ISB: TIOStatusBlock;
LibHandle: THandle;
funchandle: NTQProc;
begin
{ get file info block in this section }
libhandle := LoadLibrary('ntdll.dll');
if libhandle <> 0 then
begin
@funchandle := GetProcAddress(libhandle, 'NtQueryInformationFile');
if @funchandle <> nil then
begin
FillChar(ISB, Sizeof(ISB), 0);
FillChar(InfoBlock, sizeof(InfoBlock), 0);
FuncHandle(FHandle, ISB, InfoBlock,
sizeof(infoblock), FileStreamInformation);
end;
FreeLibrary(libhandle);
end;
end;
function procstring(P: PFileStreamInfo): string;
var
fname: ShortString;
i: integer;
begin
{ get string }
SetLength(fname, P.NameLength);
for i := 1 to P.NameLength do
fname[i] := Char(P.cStreamName[i]);
SetLength(fname, P.NameLength div 2);
{ now parse it apart }
fname := Copy(Fname, 2, Length(fname));
fname := Copy(Fname, 1, Pos(':$DATA', Fname)-1);
Result := fname;
end;
function ADSFindFirst(filename: string; var SR: TADSSearchRec): boolean;
var
FHandle: THandle;
begin
if not os_is_nt then
raise Exception.Create('A Windows NT based OS is required for this function.');
NTSetPrivilege('', SE_BACKUP_NAME, true);
FHandle := CreateFile(PChar(Filename), 0,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, 0) ;
GetFileInfoBlock(FHandle, SR.IB);
CloseHandle(FHandle);
NTSetPrivilege('', SE_BACKUP_NAME, false);
SR.IBPos := 1;
Result := ADSFindNext(SR);
end;
function ADSFindNext(var SR: TADSSearchRec): boolean;
var
P: PFileStreamInfo;
begin
P := @SR.IB[SR.IBPos];
SR.StreamSize := P^.StreamSizeLow;
SR.StreamName := ProcString(P);
if P^.NextEntry = 0 then
Result := true
else
Result := false;
Inc(SR.IBPos, P^.NextEntry);
end;
function CompressFile(filepath: string; state: boolean): boolean;
var
compsetting: Word;
bytesreturned: DWord;
FHandle: THandle;
begin
if not os_is_nt then
raise Exception.Create('A Windows NT based OS is required for this function.');
FHandle := CreateFile(PChar(filepath), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, 0);
if state = true then
compsetting := COMPRESSION_FORMAT_DEFAULT
else
compsetting := COMPRESSION_FORMAT_NONE;
if DeviceIOControl(FHandle, FSCTL_SET_COMPRESSION, @compsetting, sizeof(compsetting),
nil, 0, bytesreturned, nil) then
result := true
else
result := false;
CloseHandle(FHandle);
end;
function GetCompressedFileSize(FileName: string; var HighFileSize: DWord): DWord;
var
libhandle: THandle;
funchandle: GCSFunc;
fresult: DWord;
begin
fresult := 0;
libhandle := LoadLibrary('KERNEL32.DLL');
if libhandle <> 0 then
begin
@funchandle := GetProcAddress(libhandle, 'GetCompressedFileSizeA');
if @funchandle <> nil then
fresult := funchandle(PChar(Filename), HighFileSize);
FreeLibrary(libhandle);
end;
result := fresult;
end;
function sparse_set_file(filepath: string): boolean;
{ creates sparse file }
var
bytesreturned: DWord;
FHandle: THandle;
begin
FHandle := CreateFile(PChar(filepath), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, 0);
if DeviceIOControl(FHandle, FSCTL_SET_SPARSE, nil, 0, nil, 0,
bytesreturned, nil) then
result := true
else
result := false;
CloseHandle(FHandle);
end;
function sparse_zero_file(filepath: string; start, range: longint): boolean;
{ marks spot in file as zero length. This does not set the file pointer.
You must set the file pointer, however }
type
TZeroDataRecord = packed record
FileOffSetLow: DWord;
FileOffSetHigh: DWord;
BeyondFinalZeroLow: DWord;
BeyondFinalZeroHigh: DWord;
end;
var
ZeroData: TZeroDataRecord;
bytesreturned: DWord;
FHandle: THandle;
begin
FHandle := CreateFile(PChar(filepath), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, 0);
SetFilePointer(FHandle, start, nil, FILE_BEGIN);
FillChar(ZeroData, sizeof(ZeroData), 0);
ZeroData.FileOffSetLow := start;
ZeroData.BeyondFinalZeroLow := start + range;
if DeviceIOControl(FHandle, FSCTL_SET_ZERO_DATA, @ZeroData, sizeof(ZeroData),
nil, 0, bytesreturned, nil) then
result := true
else
result := false;
CloseHandle(FHandle);
end;
function sparse_query_ranges(filepath: string; fsbuffer: pointer;
fssize: DWord): Longint;
{ this returns all the spots in the file that HAVE allocation spaces -
actual storage can be found by using GetCompressedFileSize }
var
FHandle: THandle;
inbuffer: TRangeBuffer;
bytesreturned: DWord;
begin
FHandle := CreateFile(PChar(filepath), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, 0);
FillChar(inbuffer, Sizeof(Inbuffer), 0);
fillChar(fsbuffer^, fssize, 0);
inbuffer.FileOffsetLow := 0;
inbuffer.FileLengthLow := GetFileSize(FHandle, nil);
if DeviceIOControl(FHandle, FSCTL_QUERY_ALLOCATED_RANGES,
@inbuffer, sizeof(inbuffer),
fsbuffer, fssize,
bytesreturned, nil) then
result := bytesreturned
else
result := -1;
end;
function CreateHardLinkA(newlink, currfile: PChar; sattr: Pointer): boolean;
stdcall; external 'kernel32.dll' name 'CreateHardLinkA';
function CreateHardLink(newlink, currfile: string): boolean;
{ wrapper for function }
begin
Result := CreateHardLinkA(Pchar(Newlink), PChar(currfile), nil);
end;
end.