nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lace.environ.*: Cosmetics.

Browse Source
This commit is contained in:
Rod Kay
2022-11-12 12:55:23 +11:00
parent 6147cb0366
commit eafc137c69
8 changed files with 197 additions and 83 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
1-base/lace/source/environ/lace-environ-os_commands.adb
View File

@@ -8,6 +8,7 @@ with
ada.Characters.latin_1, ada.Characters.latin_1,
ada.Exceptions; ada.Exceptions;
package body lace.Environ.OS_Commands package body lace.Environ.OS_Commands
is is
use ada.Exceptions; use ada.Exceptions;
@@ -21,18 +22,21 @@ is
end Path_to; end Path_to;
procedure run_OS (command_Line : in String; procedure run_OS (command_Line : in String;
Input : in String := "") Input : in String := "")
is is
use Shell; use Shell;
begin begin
Commands.unsafe.run (command_Line, +Input); Commands.unsafe.run (command_Line, +Input);
exception exception
when E : Commands.command_Error => when E : Commands.command_Error =>
raise Error with Exception_Message (E); raise Error with Exception_Message (E);
end run_OS; end run_OS;
function run_OS (command_Line : in String; function run_OS (command_Line : in String;
Input : in String := ""; Input : in String := "";
add_Errors : in Boolean := True) return String add_Errors : in Boolean := True) return String
@@ -41,6 +45,7 @@ is
Shell.Commands, Shell.Commands,
Shell.Commands.unsafe; Shell.Commands.unsafe;
function trim_LF (Source : in String) return String function trim_LF (Source : in String) return String
is is
use ada.Strings.fixed, use ada.Strings.fixed,
@@ -52,8 +57,10 @@ is
return trim (Source, LF_Set, LF_Set); return trim (Source, LF_Set, LF_Set);
end trim_LF; end trim_LF;
Results : constant Command_Results := run (command_Line, +Input); Results : constant Command_Results := run (command_Line, +Input);
Output : constant String := +Output_of (Results); Output : constant String := +Output_of (Results);
begin begin
if add_Errors if add_Errors
then then
@@ -68,15 +75,19 @@ is
end run_OS; end run_OS;
function run_OS (command_Line : in String; function run_OS (command_Line : in String;
Input : in String := "") return Data Input : in String := "") return Data
is is
use Shell, use Shell,
Shell.Commands, Shell.Commands,
Shell.Commands.unsafe; Shell.Commands.unsafe;
the_Command : unsafe.Command := Forge.to_Command (command_Line); the_Command : unsafe.Command := Forge.to_Command (command_Line);
begin begin
return Output_of (run (The_Command, +Input)); return Output_of (run (The_Command, +Input));
exception exception
when E : command_Error => when E : command_Error =>
raise Error with Exception_Message (E); raise Error with Exception_Message (E);
@@ -89,8 +100,9 @@ is
use Paths, use Paths,
gnat.OS_Lib; gnat.OS_Lib;
File_Path : String_Access := Locate_Exec_On_Path (+Executable); File_Path : String_Access := locate_Exec_on_Path (+Executable);
Found : constant Boolean := File_Path /= null; Found : constant Boolean := File_Path /= null;
begin begin
free (File_Path); free (File_Path);
return Found; return Found;

10
1-base/lace/source/environ/lace-environ-os_commands.ads
View File

@@ -1,23 +1,26 @@
with with
lace.Environ.Paths; lace.Environ.Paths;
package lace.Environ.OS_Commands package lace.Environ.OS_Commands
-- --
-- Allows running of operating system commands. -- Allows running of operating system commands.
-- --
is is
function Path_to (Command : in String) return Paths.Folder; function Path_to (Command : in String) return Paths.Folder;
procedure run_OS (command_Line : in String; procedure run_OS (command_Line : in String;
Input : in String := ""); Input : in String := "");
-- --
-- Discards any output. Error is raised when the command fails. -- Discards any output. The 'Error' exception is raised if the command fails.
function run_OS (command_Line : in String; function run_OS (command_Line : in String;
Input : in String := "") return Data; Input : in String := "") return Data;
-- --
-- Returns any output. Error is raised when the command fails. -- Returns any output. The 'Error' exception is raised if the command fails.
function run_OS (command_Line : in String; function run_OS (command_Line : in String;
Input : in String := ""; Input : in String := "";
@@ -30,4 +33,5 @@ is
-- --
-- Returns True if the Executable exists on the environment PATH variable. -- Returns True if the Executable exists on the environment PATH variable.
end lace.Environ.OS_Commands; end lace.Environ.OS_Commands;

142
1-base/lace/source/environ/lace-environ-paths.adb
View File

@@ -1,6 +1,7 @@
with with
lace.Environ.OS_Commands, lace.Environ.OS_Commands,
lace.Text.utility, lace.Text.utility,
posix.file_Status, posix.file_Status,
posix.Calendar, posix.Calendar,
@@ -16,6 +17,7 @@ with
ada.Text_IO, ada.Text_IO,
ada.IO_Exceptions; ada.IO_Exceptions;
package body lace.Environ.Paths package body lace.Environ.Paths
is is
----------- -----------
@@ -26,6 +28,7 @@ is
renames to_String; renames to_String;
function expand_GLOB (GLOB : in String) return String function expand_GLOB (GLOB : in String) return String
is is
use ada.Text_IO; use ada.Text_IO;
@@ -61,6 +64,7 @@ is
end to_String; end to_String;
procedure check (Self : in Path'Class) procedure check (Self : in Path'Class)
is is
use ada.Tags, use ada.Tags,
@@ -83,6 +87,7 @@ is
end check; end check;
procedure link (Self, To : in Path) procedure link (Self, To : in Path)
is is
begin begin
@@ -95,7 +100,6 @@ is
& " " & " "
& (+To)); & (+To));
begin begin
if Output /= "" if Output /= ""
then then
raise Error with Output; raise Error with Output;
@@ -104,6 +108,7 @@ is
end link; end link;
procedure change_Mode (Self : in Path; procedure change_Mode (Self : in Path;
To : in String) To : in String)
is is
@@ -122,6 +127,7 @@ is
end change_Mode; end change_Mode;
procedure change_Owner (Self : in Path; procedure change_Owner (Self : in Path;
To : in String) To : in String)
is is
@@ -140,6 +146,7 @@ is
end change_Owner; end change_Owner;
function Exists (Self : in Path) return Boolean function Exists (Self : in Path) return Boolean
is is
begin begin
@@ -148,10 +155,11 @@ is
raise Error with "No path specified."; raise Error with "No path specified.";
end if; end if;
return ada.Directories.Exists (+Self); return ada.Directories.exists (+Self);
end Exists; end Exists;
function is_Folder (Self : in Path) return Boolean function is_Folder (Self : in Path) return Boolean
is is
use ada.Directories; use ada.Directories;
@@ -161,6 +169,7 @@ is
end is_Folder; end is_Folder;
function is_File (Self : in Path) return Boolean function is_File (Self : in Path) return Boolean
is is
use ada.Directories; use ada.Directories;
@@ -170,6 +179,7 @@ is
end is_File; end is_File;
function is_Special (Self : in Path) return Boolean function is_Special (Self : in Path) return Boolean
is is
use ada.Directories; use ada.Directories;
@@ -179,6 +189,7 @@ is
end is_Special; end is_Special;
function is_Absolute (Self : in Path) return Boolean function is_Absolute (Self : in Path) return Boolean
is is
begin begin
@@ -191,6 +202,7 @@ is
end is_Absolute; end is_Absolute;
function is_Relative (Self : in Path) return Boolean function is_Relative (Self : in Path) return Boolean
is is
begin begin
@@ -198,17 +210,18 @@ is
end is_Relative; end is_Relative;
function modify_Time (Self : in Path) return ada.Calendar.Time function modify_Time (Self : in Path) return ada.Calendar.Time
is is
begin begin
check (Self); check (Self);
declare declare
use POSIX, use Posix,
POSIX.Calendar, posix.Calendar,
POSIX.File_Status; posix.File_Status;
the_Status : constant Status := get_File_Status (pathname => to_POSIX_String (+Self)); the_Status : constant Status := get_File_Status (Pathname => to_posix_String (+Self));
Time : constant POSIX_Time := last_modification_Time_of (the_Status); Time : constant POSIX_Time := last_modification_Time_of (the_Status);
begin begin
return to_Time (Time); return to_Time (Time);
@@ -216,6 +229,7 @@ is
end modify_Time; end modify_Time;
function Parent (Self : in Path'Class) return Folder function Parent (Self : in Path'Class) return Folder
is is
begin begin
@@ -247,10 +261,11 @@ is
function Name (Self : in Path) return String function Name (Self : in Path) return String
is is
begin begin
return +Self.Name; return +Self.Name;
end Name; end Name;
function Simple (Self : in Path) return String function Simple (Self : in Path) return String
is is
begin begin
@@ -258,20 +273,21 @@ is
declare declare
use ada.Strings; use ada.Strings;
Idx : constant Natural := Index (Self.Name, "/", going => Backward); i : constant Natural := Index (Self.Name, "/", going => Backward);
Last : constant Natural := Length (Self.Name); Last : constant Natural := Length (Self.Name);
begin begin
if Idx = 0 if i = 0
then then
return +Self; return +Self;
else else
return Slice (Self.Name, Low => Idx + 1, return Slice (Self.Name, Low => i + 1,
High => Last); High => Last);
end if; end if;
end; end;
end Simple; end Simple;
----------- -----------
--- Folders --- Folders
-- --
@@ -279,15 +295,16 @@ is
function to_Folder (Name : in String) return Folder function to_Folder (Name : in String) return Folder
is is
begin begin
return (Name => To_Unbounded_String (Name)); return (Name => to_unbounded_String (Name));
end to_Folder; end to_Folder;
function "+" (Left : in Folder; Right : in Folder) return Folder function "+" (Left : in Folder; Right : in Folder) return Folder
is is
Result : Folder;
R_Folder : constant String := (if Right.is_Absolute then Right.Simple R_Folder : constant String := (if Right.is_Absolute then Right.Simple
else +Right); else +Right);
Result : Folder;
begin begin
Result.Name := Left.Name; Result.Name := Left.Name;
append (Result.Name, "/" & R_Folder); append (Result.Name, "/" & R_Folder);
@@ -296,12 +313,13 @@ is
end "+"; end "+";
function "+" (Left : in Folder'Class; function "+" (Left : in Folder'Class;
Right : in File 'Class) return File Right : in File 'Class) return File
is is
Result : File;
R_File : constant String := (if Right.is_Absolute then Right.Simple R_File : constant String := (if Right.is_Absolute then Right.Simple
else +Right); else +Right);
Result : File;
begin begin
Result.Name := Left.Name; Result.Name := Left.Name;
append (Result.Name, "/" & R_File); append (Result.Name, "/" & R_File);
@@ -310,6 +328,7 @@ is
end "+"; end "+";
function current_Folder return Folder function current_Folder return Folder
is is
begin begin
@@ -317,6 +336,7 @@ is
end current_Folder; end current_Folder;
protected folder_Lock protected folder_Lock
is is
entry change (To : in Folder); entry change (To : in Folder);
@@ -329,7 +349,7 @@ is
protected body folder_Lock protected body folder_Lock
is is
entry change (To : in Folder) entry change (To : in Folder)
when not Locked when not Locked
is is
begin begin
check (To); check (To);
@@ -337,6 +357,7 @@ is
Locked := True; Locked := True;
end change; end change;
procedure clear procedure clear
is is
begin begin
@@ -345,13 +366,14 @@ is
end folder_Lock; end folder_Lock;
procedure go_to_Folder (Self : in Folder;
Lock : in Boolean := False) procedure go_to_Folder (Self : in Folder;
lock : in Boolean := False)
is is
begin begin
check (Self); check (Self);
if Lock if lock
then then
folder_Lock.change (Self); folder_Lock.change (Self);
else else
@@ -360,6 +382,7 @@ is
end go_to_Folder; end go_to_Folder;
procedure unlock_Folder procedure unlock_Folder
is is
begin begin
@@ -367,11 +390,12 @@ is
end unlock_Folder; end unlock_Folder;
function contents_Count (Self : in Folder;
Recurse : in Boolean := False) return Natural function contents_Count (Self : in Folder;
recurse : in Boolean := False) return Natural
is is
use Shell.Directory_Iteration, use shell.Directory_Iteration,
Ada.Directories; ada.Directories;
Count : Natural := 0; Count : Natural := 0;
begin begin
@@ -382,7 +406,8 @@ is
declare declare
Name : constant String := Simple_Name (Each); Name : constant String := Simple_Name (Each);
begin begin
if not (Name = "." or Name = "..") if not ( Name = "."
or Name = "..")
then then
Count := Count + 1; Count := Count + 1;
end if; end if;
@@ -393,6 +418,7 @@ is
end contents_Count; end contents_Count;
function is_Empty (Self : in Folder) return Boolean function is_Empty (Self : in Folder) return Boolean
is is
begin begin
@@ -401,6 +427,7 @@ is
end is_Empty; end is_Empty;
procedure rid_Folder (Self : in Folder) procedure rid_Folder (Self : in Folder)
is is
begin begin
@@ -412,6 +439,7 @@ is
end rid_Folder; end rid_Folder;
procedure copy_Folder (Self : in Folder; To : in Folder) procedure copy_Folder (Self : in Folder; To : in Folder)
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
@@ -423,6 +451,7 @@ is
end copy_Folder; end copy_Folder;
procedure move_Folder (Self : in Folder; To : in Folder) procedure move_Folder (Self : in Folder; To : in Folder)
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
@@ -434,6 +463,7 @@ is
end move_Folder; end move_Folder;
procedure rename_Folder (Self : in Folder; To : in Folder) procedure rename_Folder (Self : in Folder; To : in Folder)
is is
begin begin
@@ -443,6 +473,7 @@ is
end rename_Folder; end rename_Folder;
procedure ensure_Folder (Self : in Folder) procedure ensure_Folder (Self : in Folder)
is is
begin begin
@@ -455,10 +486,12 @@ is
end ensure_Folder; end ensure_Folder;
function Relative (Self : in Folder; To : in Folder'Class) return Folder function Relative (Self : in Folder; To : in Folder'Class) return Folder
is is
use lace.Text, use lace.Text,
lace.Text.utility; lace.Text.utility;
Filename : constant lace.Text.item := to_Text (+Self); Filename : constant lace.Text.item := to_Text (+Self);
relative_Folder : constant lace.Text.item := replace (Filename, pattern => +To & "/", relative_Folder : constant lace.Text.item := replace (Filename, pattern => +To & "/",
by => ""); by => "");
@@ -467,6 +500,7 @@ is
end Relative; end Relative;
------------------- -------------------
--- Folder Contexts --- Folder Contexts
-- --
@@ -482,6 +516,7 @@ is
end push_Folder; end push_Folder;
procedure pop_Folder (Context : in out folder_Context) procedure pop_Folder (Context : in out folder_Context)
is is
begin begin
@@ -499,6 +534,7 @@ is
end pop_Folder; end pop_Folder;
procedure pop_All (Context : in out folder_Context) procedure pop_All (Context : in out folder_Context)
is is
begin begin
@@ -512,6 +548,7 @@ is
end pop_All; end pop_All;
--------- ---------
--- Files --- Files
-- --
@@ -525,6 +562,7 @@ is
end to_File; end to_File;
function "+" (Left : in File'Class; function "+" (Left : in File'Class;
Right : in File_Extension) return File Right : in File_Extension) return File
is is
@@ -533,6 +571,7 @@ is
end "+"; end "+";
function Extension (Self : in File) return File_Extension function Extension (Self : in File) return File_Extension
is is
use ada.Directories; use ada.Directories;
@@ -541,27 +580,30 @@ is
end Extension; end Extension;
procedure save (Self : in File;
Text : in String; procedure save (Self : in File; Text : in String;
Binary : in Boolean := False) Binary : in Boolean := False)
is is
begin begin
if Binary if Binary
then then
declare declare
type binary_String is new String (Text'Range); type binary_String is new String (Text'Range);
package Binary_IO is new ada.Direct_IO (binary_String); package Binary_IO is new ada.Direct_IO (binary_String);
use Binary_IO; use Binary_IO;
File : File_Type;
File : File_type;
begin begin
create (File, out_File, +Self); create (File, out_File, +Self);
write (File, binary_String (Text)); write (File, binary_String (Text));
close (File); close (File);
end; end;
else else
declare declare
use ada.Text_IO; use ada.Text_IO;
File : File_Type; File : File_type;
begin begin
create (File, out_File, +Self); create (File, out_File, +Self);
put (File, Text); put (File, Text);
@@ -571,16 +613,19 @@ is
end save; end save;
procedure save (Self : in File;
Data : in environ.Data) procedure save (Self : in File; Data : in environ.Data)
is is
begin begin
check (Self); check (Self);
declare declare
type Element_Array is new environ.Data (Data'Range); type Element_Array is new environ.Data (Data'Range);
package Binary_IO is new ada.Direct_IO (Element_Array); package Binary_IO is new ada.Direct_IO (Element_Array);
use Binary_IO; use Binary_IO;
File : File_Type;
File : File_type;
begin begin
create (File, out_File, +Self); create (File, out_File, +Self);
write (File, Element_Array (Data)); write (File, Element_Array (Data));
@@ -589,10 +634,11 @@ is
end save; end save;
function load (Self : in File) return String function load (Self : in File) return String
is is
use type ada.Directories.File_Size; use type ada.Directories.File_Size;
Size : ada.Directories.File_Size; Size : ada.Directories.File_Size;
begin begin
check (Self); check (Self);
Size := ada.Directories.Size (+Self); Size := ada.Directories.Size (+Self);
@@ -608,7 +654,7 @@ is
package String_IO is new ada.Direct_IO (my_String); package String_IO is new ada.Direct_IO (my_String);
use String_IO; use String_IO;
File : File_Type; File : File_type;
Result : my_String; Result : my_String;
begin begin
open (File, in_File, +Self); open (File, in_File, +Self);
@@ -619,15 +665,17 @@ is
end; end;
exception exception
when ada.IO_Exceptions.Name_Error => when ada.IO_Exceptions.name_Error =>
raise Error with "Cannot load missing file: '" & (+Self) & "'"; raise Error with "Cannot load missing file: '" & (+Self) & "'";
end load; end load;
function load (Self : in File) return Data function load (Self : in File) return Data
is is
begin begin
check (Self); check (Self);
declare declare
use ada.Streams; use ada.Streams;
Size : constant ada.Directories.File_Size := ada.Directories.Size (+Self); Size : constant ada.Directories.File_Size := ada.Directories.Size (+Self);
@@ -637,7 +685,7 @@ is
package Binary_IO is new ada.Direct_IO (Element_Array); package Binary_IO is new ada.Direct_IO (Element_Array);
use Binary_IO; use Binary_IO;
File : Binary_IO.File_Type; File : Binary_IO.File_type;
Result : Element_Array; Result : Element_Array;
begin begin
open (File, out_File, +Self); open (File, out_File, +Self);
@@ -648,11 +696,12 @@ is
end; end;
exception exception
when ada.IO_Exceptions.Name_Error => when ada.IO_Exceptions.name_Error =>
raise Error with "Cannot load missing file: '" & (+Self) & "'"; raise Error with "Cannot load missing file: '" & (+Self) & "'";
end load; end load;
procedure copy_File (Self : in File; To : in File) procedure copy_File (Self : in File; To : in File)
is is
begin begin
@@ -663,13 +712,14 @@ is
end copy_File; end copy_File;
procedure copy_Files (Named : in String; To : in Folder) procedure copy_Files (Named : in String; To : in Folder)
is is
use lace.Text, use lace.Text,
lace.Text.all_Tokens, lace.Text.all_Tokens,
ada.Strings.fixed; ada.Strings.fixed;
all_Files : constant String := (if Index (Named, "*") /= 0 then Expand_GLOB (Named) all_Files : constant String := (if Index (Named, "*") /= 0 then expand_GLOB (Named)
else Named); else Named);
file_List : constant Text.items_1k := Tokens (to_Text (all_Files)); file_List : constant Text.items_1k := Tokens (to_Text (all_Files));
begin begin
@@ -694,6 +744,7 @@ is
end copy_Files; end copy_Files;
procedure move_File (Self : in File; To : in File) procedure move_File (Self : in File; To : in File)
is is
begin begin
@@ -708,6 +759,7 @@ is
end move_File; end move_File;
procedure move_Files (Named : in String; To : in Folder) procedure move_Files (Named : in String; To : in Folder)
is is
begin begin
@@ -745,6 +797,7 @@ is
end move_Files; end move_Files;
procedure append (Self : in File; Text : in String) procedure append (Self : in File; Text : in String)
is is
begin begin
@@ -761,6 +814,7 @@ is
end append; end append;
procedure append_File (Self : in File; To : in File) procedure append_File (Self : in File; To : in File)
is is
begin begin
@@ -780,6 +834,7 @@ is
end append_File; end append_File;
procedure rid_File (Self : in File) procedure rid_File (Self : in File)
is is
begin begin
@@ -788,6 +843,7 @@ is
end rid_File; end rid_File;
procedure rid_Files (Named : in String) procedure rid_Files (Named : in String)
is is
use lace.Text, use lace.Text,
@@ -797,6 +853,7 @@ is
all_Files : constant String := (if Index (Named, "*") /= 0 then Expand_GLOB (Named) all_Files : constant String := (if Index (Named, "*") /= 0 then Expand_GLOB (Named)
else Named); else Named);
file_List : constant Text.items_1k := Tokens (to_Text (all_Files)); file_List : constant Text.items_1k := Tokens (to_Text (all_Files));
begin begin
for Each of file_List for Each of file_List
loop loop
@@ -806,6 +863,7 @@ is
end rid_Files; end rid_Files;
procedure touch (Self : in File) procedure touch (Self : in File)
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
@@ -818,18 +876,21 @@ is
end touch; end touch;
function Relative (Self : in File; To : in Folder'Class) return File function Relative (Self : in File; To : in Folder'Class) return File
is is
use lace.Text, use lace.Text,
lace.Text.utility; lace.Text.utility;
Filename : constant lace.Text.item := to_Text (+Self); Filename : constant lace.Text.item := to_Text (+Self);
relative_File : constant lace.Text.item := replace (Filename, pattern => +To & "/", relative_File : constant lace.Text.item := replace (Filename, Pattern => +To & "/",
by => ""); By => "");
begin begin
return to_File (+relative_File); return to_File (+relative_File);
end Relative; end Relative;
function rid_Extension (Self : in File) return File function rid_Extension (Self : in File) return File
is is
use ada.Directories; use ada.Directories;
@@ -852,6 +913,7 @@ is
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
function level_Flag return String function level_Flag return String
is is
use ada.Strings, use ada.Strings,
@@ -863,6 +925,7 @@ is
& " "; & " ";
end level_Flag; end level_Flag;
begin begin
check (the_Path); check (the_Path);
@@ -877,6 +940,7 @@ is
when Tar_Gz => "-czf", when Tar_Gz => "-czf",
when Tar_Xz => "-cJf", when Tar_Xz => "-cJf",
when others => raise program_Error); when others => raise program_Error);
Output : constant String := run_OS ( "tar " & Options Output : constant String := run_OS ( "tar " & Options
& " " & (+the_Path) & format_Suffix (the_Format) & " " & (+the_Path) & format_Suffix (the_Format)
& " " & (+the_Path)); & " " & (+the_Path));
@@ -924,6 +988,7 @@ is
end compress; end compress;
procedure decompress (Name : in File) procedure decompress (Name : in File)
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
@@ -997,6 +1062,7 @@ is
end decompress; end decompress;
function format_Suffix (Format : compress_Format) return String function format_Suffix (Format : compress_Format) return String
is is
begin begin

59
1-base/lace/source/environ/lace-environ-paths.ads
View File

@@ -6,9 +6,10 @@ with
ada.Strings.unbounded, ada.Strings.unbounded,
ada.Containers.indefinite_Vectors; ada.Containers.indefinite_Vectors;
package lace.Environ.Paths package lace.Environ.Paths
-- --
-- A singleton which models an operating system environment. -- A singleton which models an operating system paths, folders and files.
-- --
is is
@@ -41,11 +42,13 @@ is
function is_Relative (Self : in Path) return Boolean; function is_Relative (Self : in Path) return Boolean;
----------- -----------
--- Folders --- Folders
-- --
type Folder is new Path with private; type Folder is new Path with private;
no_Folder : constant Folder; no_Folder : constant Folder;
function to_Folder (Name : in String) return Folder; function to_Folder (Name : in String) return Folder;
@@ -58,7 +61,7 @@ is
procedure go_to_Folder (Self : in Folder; procedure go_to_Folder (Self : in Folder;
Lock : in Boolean := False); -- When true, blocks further folder changes until 'unlock_Folder' is called. lock : in Boolean := False); -- When true, blocks further folder changes until 'unlock_Folder' is called.
procedure unlock_Folder; procedure unlock_Folder;
@@ -66,14 +69,15 @@ is
procedure copy_Folder (Self : in Folder; To : in Folder); procedure copy_Folder (Self : in Folder; To : in Folder);
procedure move_Folder (Self : in Folder; To : in Folder); procedure move_Folder (Self : in Folder; To : in Folder);
procedure rename_Folder (Self : in Folder; To : in Folder); procedure rename_Folder (Self : in Folder; To : in Folder);
procedure ensure_Folder (Self : in Folder); -- Ensure that the folder exists. procedure ensure_Folder (Self : in Folder); -- Ensure that the folder exists.
function is_Empty (Self : in Folder) return Boolean; function is_Empty (Self : in Folder) return Boolean;
function contents_Count (Self : in Folder; -- Does not include the "." and ".." folders. function contents_Count (Self : in Folder; -- Does not include the "." and ".." folders.
Recurse : in Boolean := False) return Natural; recurse : in Boolean := False) return Natural;
function Parent (Self : in Path'Class) return Folder; -- Returns 'no_Folder' if 'Self' has no parent.
function Relative (Self : in Folder; to : in Folder'Class) return Folder;
function Parent (Self : in Path'Class) return Folder; -- Returns 'no_Folder' if 'Self' has no parent.
function Relative (Self : in Folder; To : in Folder'Class) return Folder;
------------------- -------------------
@@ -89,10 +93,13 @@ is
procedure pop_Folder (Context : in out folder_Context); procedure pop_Folder (Context : in out folder_Context);
-- --
-- Return to the previously pushed folder. -- Return to the previously pushed folder.
-- Raises 'Error' if no previous folder has been pushed.
procedure pop_All (Context : in out folder_Context); procedure pop_All (Context : in out folder_Context);
-- --
-- Return to the initial current folder. -- Return to the initial current folder.
-- Raises 'Error' if no previous folder has been pushed.
--------- ---------
@@ -110,33 +117,38 @@ is
function "+" (Left : in File'Class; function "+" (Left : in File'Class;
Right : in File_Extension) return File; Right : in File_Extension) return File;
function Extension (Self : in File) return File_Extension;
procedure save (Self : in File; function Extension (Self : in File) return File_Extension;
Text : in String;
Binary : in Boolean := False);
procedure save (Self : in File;
Data : in environ.Data);
function load (Self : in File) return String; procedure save (Self : in File; Text : in String;
function load (Self : in File) return Data; Binary : in Boolean := False);
procedure copy_File (Self : in File; To : in File); procedure save (Self : in File; Data : in environ.Data);
procedure copy_Files (Named : in String; To : in Folder);
function load (Self : in File) return String; -- Raises 'Error' if the file does not exist.
function load (Self : in File) return Data; -- Raises 'Error' if the file does not exist.
procedure copy_File (Self : in File; To : in File);
procedure copy_Files (Named : in String; To : in Folder);
-- --
-- 'Named' can contain an asterix GLOB such as "*" or "*.txt". -- 'Named' can contain an asterix GLOB such as "*" or "*.txt".
procedure move_File (Self : in File; To : in File);
procedure move_Files (Named : in String; To : in Folder); procedure move_File (Self : in File; To : in File);
procedure move_Files (Named : in String; To : in Folder);
-- --
-- 'Named' can contain an asterix GLOB such as "*" or "*.txt". -- 'Named' can contain an asterix GLOB such as "*" or "*.txt".
procedure rid_File (Self : in File);
procedure rid_Files (Named : in String); procedure rid_File (Self : in File);
procedure rid_Files (Named : in String);
-- --
-- 'Named' can contain an asterix GLOB such as "*" or "*.txt". -- 'Named' can contain an asterix GLOB such as "*" or "*.txt".
procedure append (Self : in File; Text : in String); procedure append (Self : in File; Text : in String);
procedure append_File (Self : in File; To : in File); procedure append_File (Self : in File; To : in File);
procedure touch (Self : in File); procedure touch (Self : in File);
@@ -145,12 +157,14 @@ is
function rid_Extension (Self : in File) return File; function rid_Extension (Self : in File) return File;
--- Compression --- Compression
-- --
type compress_Format is (Tar, Tar_Bz2, Tar_Gz, Tar_Xz, Bz2, Gz, Xz); type compress_Format is (Tar, Tar_Bz2, Tar_Gz, Tar_Xz, Bz2, Gz, Xz);
subtype folder_compress_Format is compress_Format range Tar .. Tar_Xz; subtype folder_compress_Format is compress_Format range Tar .. Tar_Xz;
type compress_Level is range 1 .. 9; -- Higher levels result in higher compression. type compress_Level is range 1 .. 9; -- Higher levels result in greater compression.
procedure compress (the_Path : in Path'Class; procedure compress (the_Path : in Path'Class;
the_Format : in compress_Format := Tar_Xz; the_Format : in compress_Format := Tar_Xz;
@@ -166,6 +180,7 @@ private
use ada.Strings.unbounded; use ada.Strings.unbounded;
type Path is abstract tagged type Path is abstract tagged
record record
Name : unbounded_String; Name : unbounded_String;

23
1-base/lace/source/environ/lace-environ-users.adb
View File

@@ -4,8 +4,10 @@ with
posix.user_Database, posix.user_Database,
posix.process_Identification; posix.process_Identification;
package body lace.Environ.Users package body lace.Environ.Users
is is
function "+" (Source : in unbounded_String) return String function "+" (Source : in unbounded_String) return String
renames to_String; renames to_String;
@@ -18,6 +20,7 @@ is
end to_User; end to_User;
function Name (Self : in User) return String function Name (Self : in User) return String
is is
begin begin
@@ -25,8 +28,8 @@ is
end Name; end Name;
procedure add_User (Self : in User;
Super : in Boolean := False) procedure add_User (Self : in User; Super : in Boolean := False)
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
begin begin
@@ -40,6 +43,7 @@ is
raise Error with Output; raise Error with Output;
end if; end if;
end; end;
else else
declare declare
Output : constant String := run_OS ("useradd " & (+Self.Name) & " -m"); Output : constant String := run_OS ("useradd " & (+Self.Name) & " -m");
@@ -53,9 +57,11 @@ is
end add_User; end add_User;
procedure rid_User (Self : in User) procedure rid_User (Self : in User)
is is
use lace.Environ.OS_Commands; use lace.Environ.OS_Commands;
Output : constant String := run_OS ("userdel -r " & (+Self.Name)); Output : constant String := run_OS ("userdel -r " & (+Self.Name));
begin begin
if Output /= "" if Output /= ""
@@ -65,19 +71,21 @@ is
end rid_User; end rid_User;
procedure switch_to (Self : in User) procedure switch_to (Self : in User)
is is
use Posix, use Posix,
posix.User_Database, posix.user_Database,
posix.Process_Identification; posix.process_Identification;
User_in_DB : constant User_Database_Item := get_User_Database_Item (to_Posix_String (+Self.Name)); User_in_DB : constant User_Database_item := get_User_Database_item (to_Posix_String (+Self.Name));
ID : constant User_ID := User_ID_of (User_in_DB); ID : constant User_ID := User_ID_of (User_in_DB);
begin begin
set_User_ID (ID); set_User_ID (ID);
end switch_to; end switch_to;
function current_User return User function current_User return User
is is
use Posix, use Posix,
@@ -87,13 +95,14 @@ is
end current_User; end current_User;
function home_Folder (Self : in User := current_User) return Paths.Folder function home_Folder (Self : in User := current_User) return Paths.Folder
is is
use Paths, use Paths,
Posix, Posix,
posix.User_Database; posix.user_Database;
User_in_DB : constant User_Database_Item := get_User_Database_Item (to_Posix_String (+Self.Name)); User_in_DB : constant User_Database_item := get_User_Database_item (to_Posix_String (+Self.Name));
begin begin
return to_Folder (to_String (initial_Directory_of (User_in_DB))); return to_Folder (to_String (initial_Directory_of (User_in_DB)));
end home_Folder; end home_Folder;

8
1-base/lace/source/environ/lace-environ-users.ads
View File

@@ -5,6 +5,7 @@ private
with with
ada.Strings.unbounded; ada.Strings.unbounded;
package lace.Environ.Users package lace.Environ.Users
-- --
-- Models operating system users. -- Models operating system users.
@@ -19,10 +20,9 @@ is
function current_User return User; function current_User return User;
function home_Folder (Self : in User := current_User) return Paths.Folder; function home_Folder (Self : in User := current_User) return Paths.Folder;
procedure add_User (Self : in User; procedure add_User (Self : in User; Super : in Boolean := False);
Super : in Boolean := False); procedure rid_User (Self : in User);
procedure rid_User (Self : in User); procedure switch_to (Self : in User);
procedure switch_to (Self : in User);

20
1-base/lace/source/environ/lace-environ.adb
View File

@@ -3,38 +3,42 @@ is
function to_octal_Mode (Permissions : in permission_Set) return String function to_octal_Mode (Permissions : in permission_Set) return String
is is
function octal_Permissions (Bit_3, Bit_2, Bit_1 : in Boolean) return String function octal_Permissions (Bit_3, Bit_2, Bit_1 : in Boolean) return String
is is
begin begin
if Bit_3 then if Bit_3 then
if Bit_2 then if Bit_2 then
if Bit_1 then return "7"; if Bit_1 then return "7";
else return "6"; else return "6";
end if; end if;
else else
if Bit_1 then return "5"; if Bit_1 then return "5";
else return "4"; else return "4";
end if; end if;
end if; end if;
else else
if Bit_2 then if Bit_2 then
if Bit_1 then return "3"; if Bit_1 then return "3";
else return "2"; else return "2";
end if; end if;
else else
if Bit_1 then return "1"; if Bit_1 then return "1";
else return "0"; else return "0";
end if; end if;
end if; end if;
end if; end if;
end octal_Permissions; end octal_Permissions;
begin begin
return return
octal_Permissions (Permissions (set_User_ID), Permissions (set_Group_ID), False) octal_Permissions (Permissions (set_User_ID), Permissions (set_Group_ID), False)
& octal_Permissions (Permissions (owner_Read), Permissions (owner_Write), Permissions (owner_Execute)) & octal_Permissions (Permissions (owner_Read), Permissions (owner_Write), Permissions (owner_Execute))
& octal_Permissions (Permissions (group_Read), Permissions (group_Write), Permissions (group_Execute)) & octal_Permissions (Permissions (group_Read), Permissions (group_Write), Permissions (group_Execute))
& octal_Permissions (Permissions (others_Read), Permissions (others_Write), Permissions (others_Execute)); & octal_Permissions (Permissions (others_Read), Permissions (others_Write), Permissions (others_Execute));
end to_octal_Mode; end to_octal_Mode;
end lace.Environ; end lace.Environ;

4
1-base/lace/source/environ/lace-environ.ads
View File

@@ -2,16 +2,20 @@ with
posix.Permissions, posix.Permissions,
ada.Streams; ada.Streams;
package lace.Environ package lace.Environ
-- --
-- Models an operating system environment. -- Models an operating system environment.
-- --
is is
use posix.Permissions; use posix.Permissions;
function to_octal_Mode (Permissions : in Permission_Set) return String; function to_octal_Mode (Permissions : in Permission_Set) return String;
subtype Data is ada.Streams.Stream_Element_Array; subtype Data is ada.Streams.Stream_Element_Array;
Error : exception; Error : exception;
end lace.Environ; end lace.Environ;