-- Topal: GPG/GnuPG and Alpine/Pine integration -- Copyright (C) 2001--2012 Phillip J. Brooke -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License version 3 as -- published by the Free Software Foundation. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . with Ada.Characters.Handling; with Ada.Characters.Latin_1; with Ada.Command_Line; with Ada.Integer_Text_IO; with Ada.Interrupts; with Ada.Interrupts.Names; with Ada.IO_Exceptions; with Ada.Strings; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Externals.Simple; with Help; with Version_ID; package body Misc is -- Two subprograms to make writing strings easier. procedure Character_IO_Put (F : in Character_IO.File_Type; S : in String) is begin for I in S'First..S'Last loop Character_IO.Write(F, S(I)); end loop; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Character_IO_Put"); raise; end Character_IO_Put; -- Two subprograms to make writing strings easier. procedure Character_IO_Put_Line (F : in Character_IO.File_Type; S : in String) is begin Character_IO_Put(F, S); Character_IO.Write(F, Ada.Characters.Latin_1.LF); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Character_IO_Put_Line"); raise; end Character_IO_Put_Line; -- How to handle errors and debugging. procedure Error (The_Error : in String) is begin if Ada.Text_IO.Is_Open(Result_File) then Ada.Text_IO.Put_Line(Result_File, "Topal: Fatal error: " & The_Error); end if; Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, Do_SGR(Config.UBS_Opts(Colour_Important)) & "Topal: Fatal error: " & The_Error & Reset_SGR); raise Panic with The_Error; end Error; procedure ErrorNE (The_Error : in String) is begin if Ada.Text_IO.Is_Open(Result_File) then Ada.Text_IO.Put_Line(Result_File, "Topal: Error: " & The_Error); end if; Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Topal: Error: " & The_Error); end ErrorNE; procedure Debug (Message : in String) is begin if Config.Boolean_Opts(Debug) then if Ada.Text_IO.Is_Open(Result_File) then Ada.Text_IO.Put_Line(Result_File, "Topal: Debug: " & Message); end if; Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Topal: Debug: " & Message); end if; end Debug; -- Strings to integers. function String_To_Integer (S : String) return Integer is use Ada.Integer_Text_IO; use Ada.IO_Exceptions; L : Positive; N : Integer; begin Get(S, N, L); return N; exception when Data_Error => raise String_Not_Integer; when End_Error => raise String_Not_Integer; when others => Ada.Text_IO.Put_Line("*** Problem in String_To_Integer. ***"); raise; end String_To_Integer; function String_To_Integer (S : UBS) return Integer is begin return String_To_Integer(ToStr(S)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.String_To_Integer (B)"); raise; end String_To_Integer; -- Zero pad to a length. function Zero_Pad (S : String; L : Positive) return String is begin if S'Length >= L then return S; else return Ada.Strings.Fixed."*"(L - S'Length, '0') & S; end if; end Zero_Pad; -- Throw away leading blanks from a string. function Trim_Leading_Spaces (S : String) return String is use Ada.Strings.Fixed; begin if S'Length = 0 then return S; else return S(Ada.Strings.Fixed.Index_Non_Blank(S)..S'Last); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Trim_Leading_Spaces"); raise; end Trim_Leading_Spaces; function EqualCI (A, B : String) return Boolean is use Ada.Strings.Fixed, Ada.Strings.Maps.Constants; begin return Translate(A, Lower_Case_Map) = Translate(B, Lower_Case_Map); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.EqualCI (A)"); raise; end EqualCI; function EqualCI (A, B : UBS) return Boolean is begin return EqualCI(ToStr(A), ToStr(B)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.EqualCI (B)"); raise; end EqualCI; function EqualCI (A : String; B : UBS) return Boolean is begin return EqualCI(A, ToStr(B)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.EqualCI (C)"); raise; end EqualCI; function EqualCI (A : UBS; B : String) return Boolean is begin return EqualCI(ToStr(A), B); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.EqualCI (D)"); raise; end EqualCI; -- Create our own temporary file names. To prevent collisions when -- the same Tail is used, we'll also insert a sequence number. Temp_File_Sequence_Number : Natural := 0; function Temp_File_Name (Tail : String; Use_Sequence_Number : Boolean := True) return String is begin -- If Topal_Directory doesn't exist, we'll create it. if not Externals.Simple.Test_D(ToStr(Topal_Directory)) then Externals.Simple.Mkdir_P(ToStr(Topal_Directory)); end if; if Use_Sequence_Number then Temp_File_Sequence_Number := Temp_File_Sequence_Number + 1; return ToStr(Topal_Directory) & "/temp-" & Trim_Leading_Spaces(Integer'Image(Our_PID)) & "-" & Zero_Pad(Trim_Leading_Spaces(Integer'Image(Temp_File_Sequence_Number)), 3) & "-" & Tail; else return ToStr(Topal_Directory) & "/temp-" & Trim_Leading_Spaces(Integer'Image(Our_PID)) & "-" & Tail; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Temp_File_Name"); raise; end Temp_File_Name; -- An `unbounded' Get_Line. function Unbounded_Get_Line (File : in Ada.Text_IO.File_Type) return UBS is use Ada.Text_IO; function More_Input return UBS is Input : String (1 .. 1024); Last : Natural; use type UBS; begin Get_Line(File, Input, Last); if Last < Input'Last then return ToUBS(Input(1..Last)); else return ToUBS(Input(1..Last)) & More_Input; end if; end More_Input; begin return More_Input; exception when Ada.IO_Exceptions.End_Error => -- Just let it through and let the caller sort it out. raise; when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Unbounded_Get_Line (A)"); raise; end Unbounded_Get_Line; function Unbounded_Get_Line return UBS is begin return Unbounded_Get_Line(Ada.Text_IO.Standard_Input); exception when Ada.IO_Exceptions.End_Error => -- Just let it through and let the caller sort it out. raise; when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Unbounded_Get_Line (B)"); raise; end Unbounded_Get_Line; -- Eat and fold an entire file. function Read_Fold (File : in String; Include_LF : in Boolean := False) return UBS is F : Ada.Text_IO.File_Type; U : UBS := NullUBS; Do_LF : Boolean := False; begin Debug("Opening file `" & File & "' for folded read into variable"); Ada.Text_IO.Open(File => F, Mode => Ada.Text_IO.In_File, Name => File); Read_Loop: loop declare use type UBS; begin U := U & Unbounded_Get_Line(F); -- End_Error might kick us out before appending the LF. if Do_LF then U := U & Ada.Characters.Latin_1.LF; Do_LF := False; end if; if Include_LF then Do_LF := True; end if; exception when Ada.IO_Exceptions.End_Error => exit Read_Loop; -- Okay. end; end loop Read_Loop; Ada.Text_IO.Close(File => F); return U; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Read_Fold"); raise; end Read_Fold; -- Open and close the result file. procedure Open_Result_File (Resultfile : in String) is begin Debug("Creating result file with name `" & Resultfile & "'"); Ada.Text_IO.Create(File => Result_File, Mode => Ada.Text_IO.Append_File, Name => Resultfile); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Open_Result_File"); raise; end Open_Result_File; procedure Close_Result_File is begin if Ada.Text_IO.Is_Open(Result_File) then Ada.Text_IO.Close(Result_File); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Close_Result_File"); raise; end Close_Result_File; procedure Disclaimer is use Ada.Text_IO; begin Put_Line(Do_SGR(Config.UBS_Opts(Colour_Banner)) & "Topal " & Version_ID.Release & " (" & Version_ID.Build_Date & ")"); Put_Line("Copyright (C) 2001--2012 Phillip J. Brooke" & Reset_SGR); Help.Disclaimer; New_Line; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Disclaimer"); raise; end Disclaimer; function Value_Nonempty (V : in UBS) return UBS is begin if ToStr(V) = "" then raise Need_Nonempty_String; end if; return V; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Value_Nonempty (A)"); raise; end Value_Nonempty; function Value_Nonempty (V : UBS) return String is begin return ToStr(Value_Nonempty(V)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Value_Nonempty (B)"); raise; end Value_Nonempty; -- Given a string, A, we want to split it up. Really, we would -- like to properly honour bash-style quoting. -- At the moment, we'll simply do a space-separated run. -- Then added `stuffing'. `"' will group things as an argument (i.e., stop the -- search). `"' can be included literally by stuffing: `""'. function Split_Arguments (A : UBS) return UBS_Array is BA : UVV; AS : constant String := ToStr(A); -- Recurse: -- Given a string, extract one token from it. -- Then recurse with the rest of the string. procedure Grab_Next_Token (A : in String) is I : Natural; No_More : Boolean := False; T : UBS; Quoted : Boolean := False; use type UBS; begin Debug("Grab_Next_Token invoked with `" & A & "'"); -- Only do this if we're actually been given something. if A'Length /= 0 then -- Find first non-blank. I := A'First; Start_Loop: loop if A(I) = ' ' then -- Advance. I := I + 1; -- Check for termination without finding new token. if I > A'Last then No_More := True; exit Start_Loop; end if; else -- Start of a new token. exit Start_Loop; end if; end loop Start_Loop; if not No_More then -- Copy character by character until we find a space (unless -- we're quoted!). Copy_Loop: loop if I > A'Last then exit Copy_Loop; elsif (not Quoted) and then A(I) = ' ' then I := I + 1; -- Finished. exit Copy_Loop; elsif A(I) = '"' then -- If the next character is a ", then copy just one. -- Otherwise, toggle Quoted. if I + 1 <= A'Last and then A(I + 1) = '"' then -- Literal copy of ". T := T & '"'; I := I + 2; else I := I + 1; Quoted := not Quoted; end if; else T := T & A(I); I := I + 1; end if; end loop Copy_Loop; -- Trap silliness. if Quoted then Error("Misc.Split_Arguments.Grab_Next_Token: String `" & A & "' ended inside `""'."); end if; -- Finished. BA.Append(T); -- Recurse. Grab_Next_Token(A(I .. A'Last)); end if; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Split_Arguments.Grab_Next_Token"); raise; end Grab_Next_Token; begin Debug("Split_Arguments invoked with `" & AS & "'"); BA := UVP.Empty_Vector; Grab_Next_Token(AS); declare RA : UBS_Array(0..Integer(BA.Length)-1); begin for I in 1 .. Integer(BA.Length) loop RA(I-1) := BA.Element(I); end loop; return RA; end; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Split_Arguments"); raise; end Split_Arguments; function Split_GPG_Colons (AS : String) return UBS_Array is CC : Natural; use Ada.Strings.Fixed; begin Debug("Split_GPG_Colons invoked with `" & AS & "'"); -- Count the number of colons. CC := Count(AS, ":"); declare RA : UBS_Array(0..CC); L, R : Natural; begin L := AS'First; for I in 0 .. CC loop -- Find the next right point. -- If we're working on the last entry, we don't find a colon. if I = CC then R := AS'Last; else R := Index(AS(L..AS'Last), ":") - 1; end if; -- Copy the entry... RA(I) := ToUBS(AS(L..R)); -- Update L. L := R + 2; end loop; return RA; end; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Split_GPG_Colons"); raise; end Split_GPG_Colons; function UPC (A, B : String) return UP is begin return UP'(ToUBS(A),ToUBS(B)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.UPC"); raise; end UPC; function UPC (A, B : UBS) return UP is begin return UP'(A, B); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.UPC"); raise; end UPC; -- Get the basename of a filename. function Basename (S : String) return String is -- Index of last (if any) `/'. I : Integer; begin I := Ada.Strings.Fixed.Index(Source => S, Pattern => "/", Going => Ada.Strings.Backward); if I = 0 then -- Already a basename. return S; else return S(I + 1 .. S'Last); end if; end Basename; -- Basename. function Command_Basename return String is begin return Basename(Ada.Command_Line.Command_Name); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Command_Line_Wrapper.Command_Basename"); raise; end Command_Basename; -- Turn hexadecimal string into value. function Hex_Decode (S : in String) return Natural is V : Natural := 0; begin for I in S'Range loop V := V * 16; if S(I) in '0'..'9' then V := V + Character'Pos(S(I)) - Character'Pos('0'); elsif S(I) in 'A' .. 'F' then V := V + Character'Pos(S(I)) - Character'Pos('A') + 10; elsif S(I) in 'a' .. 'f' then V := V + Character'Pos(S(I)) - Character'Pos('a') + 10; else raise Constraint_Error; end if; end loop; return V; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Hex_Decode"); raise; end Hex_Decode; -- Have we got base64 or binary? -- Test if an SMIME input is likely to be base64 or binary. We -- need this because we can't easily pass the correct -- content-transfer-encoding (yet). If Pine receives from -- Thunderbird or Outlook (for example), we are given binary. If -- it's Topal sending, then it's possibly base64. function Guess_SMIME_Encoding(Infile : String) return String is F : Character_IO.File_Type; C : Character; Limit : constant Positive := 1000; N : Natural := 0; AllB64 : Boolean := True; use Ada.Characters.Handling; use Character_IO; begin -- Open the file indicated by Infile. Read the characters. If -- any are outside the usual range for base64, return an empty -- string. If all are in that range, return "--assume-base64". Open(File => F, Mode => In_File, Name => Infile); Read_Loop: loop exit Read_Loop when End_Of_File(F); Read(F, C); N := N + 1; if not (C = ' ' or else C = Ada.Characters.Latin_1.LF or else C = Ada.Characters.Latin_1.CR or else Is_Letter(C) or else Is_Digit(C) or else C = '+' or else C = '/' or else C = '=') then AllB64 := False; exit Read_Loop; end if; exit Read_Loop when N >= Limit; end loop Read_Loop; if AllB64 then return "--assume-base64"; else return ""; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Guess_SMIME_Encoding"); raise; end Guess_SMIME_Encoding; function UGA_Str (Signing : Boolean) return String is T : Positive; begin if Signing then T := 3; else T := 2; end if; if Config.Positive_Opts(Use_Agent) >= T then return "--use-agent"; else return "--no-use-agent"; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.UGA_Str"); raise; end UGA_Str; function Use_ANSI (S : String) return String is begin if Config.Boolean_Opts(ANSI_Terminal) then return S; else return ""; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Use_ANSI"); raise; end Use_ANSI; function Do_SGR (S : String) return String is begin return Use_ANSI(ANSI_CSI & S & ANSI_SGR); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Do_SGR (A)"); raise; end Do_SGR; function Do_SGR (U : UBS) return String is begin return Do_SGR(ToStr(U)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Do_SGR (B)"); raise; end Do_SGR; function Reset_SGR return String is begin return Use_ANSI(ANSI_SGR_Reset); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Reset_SGR"); raise; end Reset_SGR; -- Rewrite a prompt. function Rewrite_Menu_Prompt (S : String) return String is U : UBS; use type UBS; begin for I in S'Range loop if S(I) = '{' then U := U & Do_SGR(Config.UBS_Opts(Colour_Menu_Key)) & "["; elsif S(I) = '}' then U := U & "]" & Reset_SGR; else U := U & S(I); end if; end loop; return ToStr(U); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Rewrite_Menu_Prompt"); raise; end Rewrite_Menu_Prompt; -- Handle signals. Default_Sigint_Handler : Ada.Interrupts.Parameterless_Handler; pragma Unreferenced(Default_Sigint_Handler); protected body Signal_Handlers is procedure Sigint_Handler is begin Ada.Text_IO.Put_Line("User interrupt!"); Sigint_Pending_Flag := True; raise User_Interrupt; end Sigint_Handler; function Sigint_Pending return Boolean is begin return Sigint_Pending_Flag; end Sigint_Pending; end Signal_Handlers; procedure Set_Sigint_Handler is begin Ada.Interrupts.Attach_Handler(Signal_Handlers.Sigint_Handler'Access, Ada.Interrupts.Names.SIGINT); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Misc.Set_Sigint_Handler"); raise; end Set_Sigint_Handler; begin Default_Sigint_Handler := Ada.Interrupts.Current_Handler(Ada.Interrupts.Names.SIGINT); end Misc;