First commit

Junctions.pas

@@ -0,0 +1,135 @@
+unit Junctions;
+
+// http://progmatix.blogspot.com/2010/10/get-target-of-symlink-in-delphi.html
+// https://delphisources.ru/pages/faq/base/hardlink_symbolic_link.html
+// http://www.flexhex.com/docs/articles/hard-links.phtml#junctions
+// https://fossil.2of4.net/zaap/artifact/ad9fc313554aea05
+
+interface
+
+const
+    FILE_ATTRIBUTE_REPARSE_POINT = 1024;
+
+function GetSymLinkTarget(const AFilename: Widestring): Widestring;
+function CreateJunction(const ALink,ADest:WideString): Boolean;
+
+implementation
+
+uses Windows;
+
+const
+  MAX_REPARSE_SIZE = 17000;
+  MAX_NAME_LENGTH = 1024;
+  REPARSE_MOUNTPOINT_HEADER_SIZE = 8;
+  IO_REPARSE_TAG_MOUNT_POINT    = $0A0000003;
+  FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
+  FILE_DEVICE_FILE_SYSTEM = $0009;
+  FILE_ANY_ACCESS = 0;
+  METHOD_BUFFERED   = 0;
+  FSCTL_SET_REPARSE_POINT    = (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or (41 shl 2) or (METHOD_BUFFERED);
+  FSCTL_GET_REPARSE_POINT    = (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or (42 shl 2) or (METHOD_BUFFERED);
+
+type
+  REPARSE_DATA_BUFFER = packed record
+    ReparseTag: DWORD;
+    ReparseDataLength: Word;
+    Reserved: Word;
+    SubstituteNameOffset: Word;
+    SubstituteNameLength: Word;
+    PrintNameOffset: Word;
+    PrintNameLength: Word;
+    PathBuffer: array[0..0] of WideChar;
+  end;
+  TReparseDataBuffer = REPARSE_DATA_BUFFER;
+  PReparseDataBuffer = ^TReparseDataBuffer;
+
+  REPARSE_MOUNTPOINT_DATA_BUFFER = packed record
+    ReparseTag: DWORD;
+    ReparseDataLength: DWORD;
+    Reserved: Word;
+    ReparseTargetLength: Word;
+    ReparseTargetMaximumLength: Word;
+    Reserved1: Word;
+    ReparseTarget: array[0..0] of WideChar;
+  end;
+  TReparseMountPointDataBuffer = REPARSE_MOUNTPOINT_DATA_BUFFER;
+  PReparseMountPointDataBuffer = ^TReparseMountPointDataBuffer;
+
+  Function CreateSymbolicLinkW(Src,Target:PWideChar;Flags:Cardinal):BOOL; Stdcall; External 'kernel32.dll';
+
+function OpenDirectory(const ADir:WideString;bReadWrite:Boolean):THandle;
+var
+  token:THandle;
+  tp:TTokenPrivileges;
+  bp:WideString;
+  dw,access:DWORD;
+begin
+  // Obtain backup/restore privilege in case we don't have it
+  OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, token);
+  If bReadWrite Then bp:='SeRestorePrivilege' else bp:='SeBackupPrivilege';
+  LookupPrivilegeValueW(NIL, PWideChar(bp), tp.Privileges[0].Luid);
+  tp.PrivilegeCount := 1;
+  tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+  AdjustTokenPrivileges(token, FALSE, tp, sizeof(TOKEN_PRIVILEGES), NIL, dw);
+  CloseHandle(token);
+
+  // Open the directory
+  access:=GENERIC_READ;
+  if bReadWrite then access:=access or GENERIC_WRITE;
+  Result := CreateFileW(PWideChar(ADir), access, 0, NIL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT or FILE_FLAG_BACKUP_SEMANTICS, 0);
+end;
+
+function GetSymLinkTarget(const AFilename: WideString): Widestring;
+var
+  hDir:THandle;
+  nRes:DWORD;
+  reparseInfo: PReparseDataBuffer;
+  name2: array[0..MAX_NAME_LENGTH-1] of WideChar;
+begin
+  Result := '';
+  hDir:= OpenDirectory(AFilename,False);
+  if hDir = INVALID_HANDLE_VALUE then Exit;
+  GetMem(reparseInfo,MAX_REPARSE_SIZE);
+  if DeviceIoControl(hDir, FSCTL_GET_REPARSE_POINT, nil, 0, reparseInfo, MAX_REPARSE_SIZE, nRes, nil) Then
+    If reparseInfo.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT then
+    Begin
+      FillChar(name2, SizeOf(name2), 0);
+      lstrcpynW(name2, reparseInfo.PathBuffer + reparseInfo.SubstituteNameOffset, reparseInfo.SubstituteNameLength);
+      Result:= Copy(name2,5,Length(name2)); // remove the '\??\' prefix
+    end;
+  FreeMem(reparseInfo,MAX_REPARSE_SIZE);
+  CloseHandle(hDir);
+end;
+
+// target must NOT begin with "\??\" - it will be added automatically
+Function CreateJunction(const ALink,ADest:WideString):Boolean;
+Const
+  LinkPrefix: WideString = '\??\';
+var
+  Buffer: PReparseMountPointDataBuffer;
+  BufSize: integer;
+  TargetName: WideString;
+  hDir:THandle;
+  dw:DWORD;
+Begin
+  Result:=False;
+  hDir:=OpenDirectory(ALink,True);
+  If hDir = INVALID_HANDLE_VALUE then Exit;
+  If Pos(LinkPrefix,ADest)=1 then TargetName:=ADest else TargetName:=LinkPrefix+ADest;
+  BufSize:=(Length(TargetName)+1)*SizeOf(WideChar) + REPARSE_MOUNTPOINT_HEADER_SIZE + 12;
+  GetMem(Buffer,BufSize);
+  FillChar(Buffer^,BufSize,#0);
+  With Buffer^ Do
+  Begin
+    Move(TargetName[1], ReparseTarget, (Length(TargetName)+1)*SizeOf(WideChar));
+    ReparseTag:= IO_REPARSE_TAG_MOUNT_POINT;
+    ReparseTargetLength:= Length(TargetName)*SizeOf(WideChar);
+    ReparseTargetMaximumLength:= ReparseTargetLength+2;
+    ReparseDataLength:= ReparseTargetLength+12;
+  end;
+  Result:=DeviceIoControl(hDir,FSCTL_SET_REPARSE_POINT,Buffer,Buffer.ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE,Nil,0,dw,Nil);
+  FreeMem(Buffer,BufSize);
+  CloseHandle(hDir);
+end;
+
+end.

Main.dfm

@@ -0,0 +1,243 @@
+object frmUI: TfrmUI
+  Left = 263
+  Top = 110
+  ActiveControl = vdSize
+  BorderIcons = [biSystemMenu, biMinimize]
+  BorderStyle = bsSingle
+  Caption = 'RAMdisk UI'
+  ClientHeight = 522
+  ClientWidth = 303
+  Color = clBtnFace
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  Position = poScreenCenter
+  OnCreate = FormCreate
+  OnShow = FormShow
+  PixelsPerInch = 96
+  TextHeight = 13
+  object txtDrive: TLabel
+    Left = 40
+    Top = 72
+    Width = 58
+    Height = 13
+    Caption = 'Drive letter:'
+  end
+  object txtContent: TLabel
+    Left = 14
+    Top = 132
+    Width = 119
+    Height = 13
+    Caption = 'Load content from folder'
+  end
+  object vdSize: TLabeledEdit
+    Left = 36
+    Top = 24
+    Width = 61
+    Height = 21
+    Hint = 'Minimum 3MB'
+    EditLabel.Width = 23
+    EditLabel.Height = 13
+    EditLabel.Caption = 'Size:'
+    LabelPosition = lpLeft
+    MaxLength = 4
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 0
+  end
+  object radioMB: TRadioButton
+    Left = 108
+    Top = 16
+    Width = 57
+    Height = 17
+    Caption = 'MB'
+    Checked = True
+    TabOrder = 1
+    TabStop = True
+  end
+  object radioGB: TRadioButton
+    Left = 108
+    Top = 40
+    Width = 57
+    Height = 17
+    Caption = 'GB'
+    TabOrder = 2
+  end
+  object comboLetter: TComboBox
+    Left = 108
+    Top = 68
+    Width = 41
+    Height = 21
+    Style = csDropDownList
+    ItemHeight = 13
+    Sorted = True
+    TabOrder = 3
+  end
+  object chkTemp: TCheckBox
+    Left = 12
+    Top = 100
+    Width = 273
+    Height = 17
+    Caption = 'Create TEMP folder and set environment variables'
+    TabOrder = 4
+  end
+  object btnLoad: TButton
+    Left = 248
+    Top = 150
+    Width = 32
+    Height = 25
+    Caption = '...'
+    TabOrder = 6
+    OnClick = btnLoadClick
+  end
+  object chkSync: TCheckBox
+    Left = 12
+    Top = 184
+    Width = 225
+    Height = 17
+    Hint = 
+      'Copy RAM-disk contents back to the '#13#10'same folder where it was in' +
+      'itialized from.'
+    Caption = 'Synchronize at shutdown'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 7
+    OnClick = chkSyncClick
+  end
+  object grpSync: TGroupBox
+    Left = 16
+    Top = 220
+    Width = 269
+    Height = 169
+    Caption = ' Do not persist these folders (no wildcards) '
+    Enabled = False
+    TabOrder = 8
+    object chkDelete: TCheckBox
+      Left = 8
+      Top = 24
+      Width = 249
+      Height = 17
+      Hint = 
+        'Delete files and folders from the INIT '#13#10'folder that are not pre' +
+        'sent on the RAM-disk.'
+      Caption = 'Delete data removed from RAMdisk'
+      ParentShowHint = False
+      ShowHint = True
+      TabOrder = 0
+    end
+    object memoIgnore: TTntMemo
+      Left = 2
+      Top = 52
+      Width = 265
+      Height = 115
+      Hint = 
+        'One folder per line,'#13#10'no wildcards, no subfolders,'#13#10'no drive let' +
+        'ter - folders are'#13#10'relative to the root of RAM-disk'
+      Align = alBottom
+      Anchors = [akLeft, akTop, akRight, akBottom]
+      HideSelection = False
+      ParentShowHint = False
+      ScrollBars = ssBoth
+      ShowHint = True
+      TabOrder = 1
+    end
+  end
+  object btnSave: TButton
+    Left = 16
+    Top = 398
+    Width = 125
+    Height = 48
+    Caption = 'Save now - apply on reboot'
+    TabOrder = 9
+    WordWrap = True
+    OnClick = btnSaveClick
+  end
+  object btnApply: TButton
+    Left = 160
+    Top = 398
+    Width = 125
+    Height = 48
+    Caption = 'Save and apply now'
+    TabOrder = 10
+    WordWrap = True
+    OnClick = btnApplyClick
+  end
+  object btnQuit: TButton
+    Left = 104
+    Top = 489
+    Width = 101
+    Height = 28
+    Caption = 'Quit'
+    TabOrder = 11
+    OnClick = btnQuitClick
+  end
+  object grpRAM: TGroupBox
+    Left = 176
+    Top = 12
+    Width = 105
+    Height = 77
+    Caption = ' Active '
+    TabOrder = 12
+    object lamp: TShape
+      Left = 8
+      Top = 48
+      Width = 16
+      Height = 16
+      Brush.Color = clLime
+      Shape = stCircle
+    end
+    object txtSize: TLabel
+      Left = 12
+      Top = 16
+      Width = 81
+      Height = 16
+      Alignment = taCenter
+      AutoSize = False
+      ShowAccelChar = False
+      Layout = tlCenter
+    end
+    object btnUnmount: TButton
+      Left = 32
+      Top = 44
+      Width = 67
+      Height = 25
+      Caption = 'Unmount'
+      Enabled = False
+      TabOrder = 0
+      OnClick = btnUnmountClick
+    end
+  end
+  object editFolder: TTntEdit
+    Left = 12
+    Top = 152
+    Width = 229
+    Height = 21
+    Hint = 
+      'If you select a folder - its entire content will be'#13#10'copied to t' +
+      'he RAM-disk. Symlinks are recognized.'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 5
+  end
+  object btnInstall: TButton
+    Left = 16
+    Top = 454
+    Width = 125
+    Height = 28
+    Caption = 'Install service'
+    TabOrder = 13
+    OnClick = btnInstallClick
+  end
+  object btnUninstall: TButton
+    Left = 160
+    Top = 454
+    Width = 125
+    Height = 28
+    Caption = 'Uninstall service'
+    TabOrder = 14
+    OnClick = btnUninstallClick
+  end
+end