Skip to content

Commit 9ecbd94

Browse files
tmcdostmcdos
committed
First commit
1 parent d20712a commit 9ecbd94

25 files changed

+4020
-0
lines changed

‎Definitions.pas‎

Lines changed: 445 additions & 0 deletions
Large diffs are not rendered by default.

‎Junctions.pas‎

Lines changed: 135 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,135 @@
1+
unit Junctions;
2+
3+
// http://progmatix.blogspot.com/2010/10/get-target-of-symlink-in-delphi.html
4+
// https://delphisources.ru/pages/faq/base/hardlink_symbolic_link.html
5+
// http://www.flexhex.com/docs/articles/hard-links.phtml#junctions
6+
// https://fossil.2of4.net/zaap/artifact/ad9fc313554aea05
7+
8+
interface
9+
10+
const
11+
FILE_ATTRIBUTE_REPARSE_POINT = 1024;
12+
13+
function GetSymLinkTarget(const AFilename: Widestring): Widestring;
14+
function CreateJunction(const ALink,ADest:WideString): Boolean;
15+
16+
implementation
17+
18+
uses Windows;
19+
20+
const
21+
MAX_REPARSE_SIZE = 17000;
22+
MAX_NAME_LENGTH = 1024;
23+
REPARSE_MOUNTPOINT_HEADER_SIZE = 8;
24+
IO_REPARSE_TAG_MOUNT_POINT = $0A0000003;
25+
FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
26+
FILE_DEVICE_FILE_SYSTEM = $0009;
27+
FILE_ANY_ACCESS = 0;
28+
METHOD_BUFFERED = 0;
29+
FSCTL_SET_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or (41 shl 2) or (METHOD_BUFFERED);
30+
FSCTL_GET_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or (42 shl 2) or (METHOD_BUFFERED);
31+
32+
type
33+
REPARSE_DATA_BUFFER = packed record
34+
ReparseTag: DWORD;
35+
ReparseDataLength: Word;
36+
Reserved: Word;
37+
SubstituteNameOffset: Word;
38+
SubstituteNameLength: Word;
39+
PrintNameOffset: Word;
40+
PrintNameLength: Word;
41+
PathBuffer: array[0..0] of WideChar;
42+
end;
43+
TReparseDataBuffer = REPARSE_DATA_BUFFER;
44+
PReparseDataBuffer = ^TReparseDataBuffer;
45+
46+
REPARSE_MOUNTPOINT_DATA_BUFFER = packed record
47+
ReparseTag: DWORD;
48+
ReparseDataLength: DWORD;
49+
Reserved: Word;
50+
ReparseTargetLength: Word;
51+
ReparseTargetMaximumLength: Word;
52+
Reserved1: Word;
53+
ReparseTarget: array[0..0] of WideChar;
54+
end;
55+
TReparseMountPointDataBuffer = REPARSE_MOUNTPOINT_DATA_BUFFER;
56+
PReparseMountPointDataBuffer = ^TReparseMountPointDataBuffer;
57+
58+
Function CreateSymbolicLinkW(Src,Target:PWideChar;Flags:Cardinal):BOOL; Stdcall; External 'kernel32.dll';
59+
60+
function OpenDirectory(const ADir:WideString;bReadWrite:Boolean):THandle;
61+
var
62+
token:THandle;
63+
tp:TTokenPrivileges;
64+
bp:WideString;
65+
dw,access:DWORD;
66+
begin
67+
// Obtain backup/restore privilege in case we don't have it
68+
OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, token);
69+
If bReadWrite Then bp:='SeRestorePrivilege' else bp:='SeBackupPrivilege';
70+
LookupPrivilegeValueW(NIL, PWideChar(bp), tp.Privileges[0].Luid);
71+
tp.PrivilegeCount := 1;
72+
tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
73+
AdjustTokenPrivileges(token, FALSE, tp, sizeof(TOKEN_PRIVILEGES), NIL, dw);
74+
CloseHandle(token);
75+
76+
// Open the directory
77+
access:=GENERIC_READ;
78+
if bReadWrite then access:=access or GENERIC_WRITE;
79+
Result := CreateFileW(PWideChar(ADir), access, 0, NIL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT or FILE_FLAG_BACKUP_SEMANTICS, 0);
80+
end;
81+
82+
function GetSymLinkTarget(const AFilename: WideString): Widestring;
83+
var
84+
hDir:THandle;
85+
nRes:DWORD;
86+
reparseInfo: PReparseDataBuffer;
87+
name2: array[0..MAX_NAME_LENGTH-1] of WideChar;
88+
begin
89+
Result := '';
90+
hDir:= OpenDirectory(AFilename,False);
91+
if hDir = INVALID_HANDLE_VALUE then Exit;
92+
GetMem(reparseInfo,MAX_REPARSE_SIZE);
93+
if DeviceIoControl(hDir, FSCTL_GET_REPARSE_POINT, nil, 0, reparseInfo, MAX_REPARSE_SIZE, nRes, nil) Then
94+
If reparseInfo.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT then
95+
Begin
96+
FillChar(name2, SizeOf(name2), 0);
97+
lstrcpynW(name2, reparseInfo.PathBuffer + reparseInfo.SubstituteNameOffset, reparseInfo.SubstituteNameLength);
98+
Result:= Copy(name2,5,Length(name2)); // remove the '\??\' prefix
99+
end;
100+
FreeMem(reparseInfo,MAX_REPARSE_SIZE);
101+
CloseHandle(hDir);
102+
end;
103+
104+
// target must NOT begin with "\??\" - it will be added automatically
105+
Function CreateJunction(const ALink,ADest:WideString):Boolean;
106+
Const
107+
LinkPrefix: WideString = '\??\';
108+
var
109+
Buffer: PReparseMountPointDataBuffer;
110+
BufSize: integer;
111+
TargetName: WideString;
112+
hDir:THandle;
113+
dw:DWORD;
114+
Begin
115+
Result:=False;
116+
hDir:=OpenDirectory(ALink,True);
117+
If hDir = INVALID_HANDLE_VALUE then Exit;
118+
If Pos(LinkPrefix,ADest)=1 then TargetName:=ADest else TargetName:=LinkPrefix+ADest;
119+
BufSize:=(Length(TargetName)+1)*SizeOf(WideChar) + REPARSE_MOUNTPOINT_HEADER_SIZE + 12;
120+
GetMem(Buffer,BufSize);
121+
FillChar(Buffer^,BufSize,#0);
122+
With Buffer^ Do
123+
Begin
124+
Move(TargetName[1], ReparseTarget, (Length(TargetName)+1)*SizeOf(WideChar));
125+
ReparseTag:= IO_REPARSE_TAG_MOUNT_POINT;
126+
ReparseTargetLength:= Length(TargetName)*SizeOf(WideChar);
127+
ReparseTargetMaximumLength:= ReparseTargetLength+2;
128+
ReparseDataLength:= ReparseTargetLength+12;
129+
end;
130+
Result:=DeviceIoControl(hDir,FSCTL_SET_REPARSE_POINT,Buffer,Buffer.ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE,Nil,0,dw,Nil);
131+
FreeMem(Buffer,BufSize);
132+
CloseHandle(hDir);
133+
end;
134+
135+
end.

‎Main.dfm‎

Lines changed: 243 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,243 @@
1+
object frmUI: TfrmUI
2+
Left = 263
3+
Top = 110
4+
ActiveControl = vdSize
5+
BorderIcons = [biSystemMenu, biMinimize]
6+
BorderStyle = bsSingle
7+
Caption = 'RAMdisk UI'
8+
ClientHeight = 522
9+
ClientWidth = 303
10+
Color = clBtnFace
11+
Font.Charset = DEFAULT_CHARSET
12+
Font.Color = clWindowText
13+
Font.Height = -11
14+
Font.Name = 'Tahoma'
15+
Font.Style = []
16+
OldCreateOrder = False
17+
Position = poScreenCenter
18+
OnCreate = FormCreate
19+
OnShow = FormShow
20+
PixelsPerInch = 96
21+
TextHeight = 13
22+
object txtDrive: TLabel
23+
Left = 40
24+
Top = 72
25+
Width = 58
26+
Height = 13
27+
Caption = 'Drive letter:'
28+
end
29+
object txtContent: TLabel
30+
Left = 14
31+
Top = 132
32+
Width = 119
33+
Height = 13
34+
Caption = 'Load content from folder'
35+
end
36+
object vdSize: TLabeledEdit
37+
Left = 36
38+
Top = 24
39+
Width = 61
40+
Height = 21
41+
Hint = 'Minimum 3MB'
42+
EditLabel.Width = 23
43+
EditLabel.Height = 13
44+
EditLabel.Caption = 'Size:'
45+
LabelPosition = lpLeft
46+
MaxLength = 4
47+
ParentShowHint = False
48+
ShowHint = True
49+
TabOrder = 0
50+
end
51+
object radioMB: TRadioButton
52+
Left = 108
53+
Top = 16
54+
Width = 57
55+
Height = 17
56+
Caption = 'MB'
57+
Checked = True
58+
TabOrder = 1
59+
TabStop = True
60+
end
61+
object radioGB: TRadioButton
62+
Left = 108
63+
Top = 40
64+
Width = 57
65+
Height = 17
66+
Caption = 'GB'
67+
TabOrder = 2
68+
end
69+
object comboLetter: TComboBox
70+
Left = 108
71+
Top = 68
72+
Width = 41
73+
Height = 21
74+
Style = csDropDownList
75+
ItemHeight = 13
76+
Sorted = True
77+
TabOrder = 3
78+
end
79+
object chkTemp: TCheckBox
80+
Left = 12
81+
Top = 100
82+
Width = 273
83+
Height = 17
84+
Caption = 'Create TEMP folder and set environment variables'
85+
TabOrder = 4
86+
end
87+
object btnLoad: TButton
88+
Left = 248
89+
Top = 150
90+
Width = 32
91+
Height = 25
92+
Caption = '...'
93+
TabOrder = 6
94+
OnClick = btnLoadClick
95+
end
96+
object chkSync: TCheckBox
97+
Left = 12
98+
Top = 184
99+
Width = 225
100+
Height = 17
101+
Hint =
102+
'Copy RAM-disk contents back to the '#13#10'same folder where it was in' +
103+
'itialized from.'
104+
Caption = 'Synchronize at shutdown'
105+
ParentShowHint = False
106+
ShowHint = True
107+
TabOrder = 7
108+
OnClick = chkSyncClick
109+
end
110+
object grpSync: TGroupBox
111+
Left = 16
112+
Top = 220
113+
Width = 269
114+
Height = 169
115+
Caption = ' Do not persist these folders (no wildcards) '
116+
Enabled = False
117+
TabOrder = 8
118+
object chkDelete: TCheckBox
119+
Left = 8
120+
Top = 24
121+
Width = 249
122+
Height = 17
123+
Hint =
124+
'Delete files and folders from the INIT '#13#10'folder that are not pre' +
125+
'sent on the RAM-disk.'
126+
Caption = 'Delete data removed from RAMdisk'
127+
ParentShowHint = False
128+
ShowHint = True
129+
TabOrder = 0
130+
end
131+
object memoIgnore: TTntMemo
132+
Left = 2
133+
Top = 52
134+
Width = 265
135+
Height = 115
136+
Hint =
137+
'One folder per line,'#13#10'no wildcards, no subfolders,'#13#10'no drive let' +
138+
'ter - folders are'#13#10'relative to the root of RAM-disk'
139+
Align = alBottom
140+
Anchors = [akLeft, akTop, akRight, akBottom]
141+
HideSelection = False
142+
ParentShowHint = False
143+
ScrollBars = ssBoth
144+
ShowHint = True
145+
TabOrder = 1
146+
end
147+
end
148+
object btnSave: TButton
149+
Left = 16
150+
Top = 398
151+
Width = 125
152+
Height = 48
153+
Caption = 'Save now - apply on reboot'
154+
TabOrder = 9
155+
WordWrap = True
156+
OnClick = btnSaveClick
157+
end
158+
object btnApply: TButton
159+
Left = 160
160+
Top = 398
161+
Width = 125
162+
Height = 48
163+
Caption = 'Save and apply now'
164+
TabOrder = 10
165+
WordWrap = True
166+
OnClick = btnApplyClick
167+
end
168+
object btnQuit: TButton
169+
Left = 104
170+
Top = 489
171+
Width = 101
172+
Height = 28
173+
Caption = 'Quit'
174+
TabOrder = 11
175+
OnClick = btnQuitClick
176+
end
177+
object grpRAM: TGroupBox
178+
Left = 176
179+
Top = 12
180+
Width = 105
181+
Height = 77
182+
Caption = ' Active '
183+
TabOrder = 12
184+
object lamp: TShape
185+
Left = 8
186+
Top = 48
187+
Width = 16
188+
Height = 16
189+
Brush.Color = clLime
190+
Shape = stCircle
191+
end
192+
object txtSize: TLabel
193+
Left = 12
194+
Top = 16
195+
Width = 81
196+
Height = 16
197+
Alignment = taCenter
198+
AutoSize = False
199+
ShowAccelChar = False
200+
Layout = tlCenter
201+
end
202+
object btnUnmount: TButton
203+
Left = 32
204+
Top = 44
205+
Width = 67
206+
Height = 25
207+
Caption = 'Unmount'
208+
Enabled = False
209+
TabOrder = 0
210+
OnClick = btnUnmountClick
211+
end
212+
end
213+
object editFolder: TTntEdit
214+
Left = 12
215+
Top = 152
216+
Width = 229
217+
Height = 21
218+
Hint =
219+
'If you select a folder - its entire content will be'#13#10'copied to t' +
220+
'he RAM-disk. Symlinks are recognized.'
221+
ParentShowHint = False
222+
ShowHint = True
223+
TabOrder = 5
224+
end
225+
object btnInstall: TButton
226+
Left = 16
227+
Top = 454
228+
Width = 125
229+
Height = 28
230+
Caption = 'Install service'
231+
TabOrder = 13
232+
OnClick = btnInstallClick
233+
end
234+
object btnUninstall: TButton
235+
Left = 160
236+
Top = 454
237+
Width = 125
238+
Height = 28
239+
Caption = 'Uninstall service'
240+
TabOrder = 14
241+
OnClick = btnUninstallClick
242+
end
243+
end

0 commit comments

Comments
 (0)