lace.environ.*: Cosmetics.

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

View File

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

View File

@@ -1,23 +1,26 @@
with
lace.Environ.Paths;
package lace.Environ.OS_Commands
--
-- Allows running of operating system commands.
--
is
function Path_to (Command : in String) return Paths.Folder;
procedure run_OS (command_Line : 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;
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;
Input : in String := "";
@@ -30,4 +33,5 @@ is
--
-- Returns True if the Executable exists on the environment PATH variable.
end lace.Environ.OS_Commands;

View File

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

View File

@@ -6,9 +6,10 @@ with
ada.Strings.unbounded,
ada.Containers.indefinite_Vectors;
package lace.Environ.Paths
--
-- A singleton which models an operating system environment.
-- A singleton which models an operating system paths, folders and files.
--
is
@@ -41,11 +42,13 @@ is
function is_Relative (Self : in Path) return Boolean;
-----------
--- Folders
--
type Folder is new Path with private;
no_Folder : constant Folder;
function to_Folder (Name : in String) return Folder;
@@ -58,7 +61,7 @@ is
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;
@@ -66,14 +69,15 @@ is
procedure copy_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 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 contents_Count (Self : in Folder; -- Does not include the "." and ".." folders.
Recurse : in Boolean := False) return Natural;
function contents_Count (Self : in Folder; -- Does not include the "." and ".." folders.
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);
--
-- Return to the previously pushed folder.
-- Raises 'Error' if no previous folder has been pushed.
procedure pop_All (Context : in out folder_Context);
--
-- 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;
Right : in File_Extension) return File;
function Extension (Self : in File) return File_Extension;
procedure save (Self : in File;
Text : in String;
Binary : in Boolean := False);
function Extension (Self : in File) return File_Extension;
procedure save (Self : in File;
Data : in environ.Data);
function load (Self : in File) return String;
function load (Self : in File) return Data;
procedure save (Self : in File; Text : in String;
Binary : in Boolean := False);
procedure copy_File (Self : in File; To : in File);
procedure copy_Files (Named : in String; To : in Folder);
procedure save (Self : in File; Data : in environ.Data);
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".
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".
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".
procedure append (Self : in File; Text : in String);
procedure append_File (Self : in File; To : in File);
procedure touch (Self : in File);
@@ -145,12 +157,14 @@ is
function rid_Extension (Self : in File) return File;
--- Compression
--
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;
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;
the_Format : in compress_Format := Tar_Xz;
@@ -166,6 +180,7 @@ private
use ada.Strings.unbounded;
type Path is abstract tagged
record
Name : unbounded_String;

View File

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

View File

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

View File

@@ -3,38 +3,42 @@ is
function to_octal_Mode (Permissions : in permission_Set) return String
is
function octal_Permissions (Bit_3, Bit_2, Bit_1 : in Boolean) return String
is
begin
if Bit_3 then
if Bit_2 then
if Bit_1 then return "7";
else return "6";
else return "6";
end if;
else
if Bit_1 then return "5";
else return "4";
else return "4";
end if;
end if;
else
if Bit_2 then
if Bit_1 then return "3";
else return "2";
else return "2";
end if;
else
if Bit_1 then return "1";
else return "0";
else return "0";
end if;
end if;
end if;
end octal_Permissions;
begin
return
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 (group_Read), Permissions (group_Write), Permissions (group_Execute))
& octal_Permissions (Permissions (others_Read), Permissions (others_Write), Permissions (others_Execute));
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 (group_Read), Permissions (group_Write), Permissions (group_Execute))
& octal_Permissions (Permissions (others_Read), Permissions (others_Write), Permissions (others_Execute));
end to_octal_Mode;
end lace.Environ;

View File

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