-- This source is licensed under the Sunset License v1.0 with Ada.Characters.Latin_1, Ada.Directories, Ada.Strings.Fixed, Ada.Strings.Maps, Ada.Text_IO, Deckdata.CSV, Deckdata.FMD, GNAT.Regpat, GNATCOLL.JSON, UnZip; package body Deckdata.IO is package Latin renames Ada.Characters.Latin_1; package FD renames Ada.Directories; package Strfix renames Ada.Strings.Fixed; package Strmap renames Ada.Strings.Maps; package TIO renames Ada.Text_IO; package Pat renames GNAT.Regpat; package JS renames GNATCOLL.JSON; function To_Unbounded_String (Item : in Field_ID) return SU.Unbounded_String is begin return SU.Unbounded_String (Item); end To_Unbounded_String; function To_Unbounded_String (Item : in Field) return SU.Unbounded_String is begin return SU.Unbounded_String (Item); end To_Unbounded_String; procedure Finalize (This : in out Deck_Handle) is begin if This.Opened then FD.Delete_File (-This.Tempfile); end if; end Finalize; function Generate_Temp_Name return String is Handle : TIO.File_Type; Filename : SU.Unbounded_String; begin TIO.Create (File => Handle); Filename := +TIO.Name (Handle); TIO.Close (Handle); return -Filename; end Generate_Temp_Name; function Matches (Models : in Model_Map; Notes : in Note_Vector) return Boolean is use type Ada.Containers.Count_Type; begin for Note of Notes loop if not Models.Contains (Note.Model) or else Note.Fields.Length > Models.Element (Note.Model).Fields.Length then return False; end if; end loop; return True; end Matches; procedure Read_Media_Collection (Filename : in String; Media : out Media_Collection) is Temp : String := Generate_Temp_Name; Input_Handle : TIO.File_Type; Raw_Data : SU.Unbounded_String; JSON_Data : JS.JSON_Value; procedure Map_Iteration (Name : in JS.UTF8_String; Value : in JS.JSON_Value) is Val : SU.Unbounded_String := JS.Get (Value); begin Media.Map.Insert (Media_Name (Val), Media_ID (+Name)); end Map_Iteration; begin UnZip.Extract (Filename, "media", Temp); TIO.Open (Input_Handle, TIO.In_File, Temp); while not TIO.End_Of_File (Input_Handle) loop SU.Append (Raw_Data, TIO.Get_Line (Input_Handle) & Latin.LF); end loop; TIO.Close (Input_Handle); FD.Delete_File (Temp); JSON_Data := JS.Read (-Raw_Data); JS.Map_JSON_Object (JSON_Data, Map_Iteration'Access); Media.Filename := +Filename; end Read_Media_Collection; procedure Open_Database (Filename : in String; Deck : in out Deck_Handle) is Temp : String := Generate_Temp_Name; begin UnZip.Extract (Filename, "collection.anki2", Temp); Deck.SQL_Handle.Open (Temp); Deck.Opened := True; Deck.Tempfile := +Temp; end Open_Database; function Is_Open (Deck : in Deck_Handle) return Boolean is begin return Deck.Opened; end Is_Open; procedure Close_Database (Deck : in out Deck_Handle) is begin if Deck.Opened = False then return; end if; Deck.SQL_Handle.Close; Deck.Opened := False; FD.Delete_File (-Deck.Tempfile); Deck.Tempfile := +""; end Close_Database; procedure Extract_Field_IDs (Value : in JS.JSON_Array; FIDs : out Field_ID_Vector) is Index : Positive; Item : JS.JSON_Value; Ordinal : Integer; begin Index := JS.Array_First (Value); while JS.Array_Has_Element (Value, Index) loop Item := JS.Array_Element (Value, Index); Ordinal := JS.Get (Item, "ord") + 1; if Ordinal > Integer (FIDs.Length) then FIDs.Set_Length (Ada.Containers.Count_Type (Ordinal)); end if; declare Name : String := JS.Get (Item, "name"); begin FIDs.Replace_Element (Field_Ordinal (Ordinal), Field_ID (+Name)); end; Index := Index + 1; end loop; end Extract_Field_IDs; procedure Regex_Fields (Raw_Data : in JS.UTF8_String; FIDs : out Field_ID_Vector) is use type Pat.Match_Location; Matches : Pat.Match_Array (0 .. 1); Regexp : Pat.Pattern_Matcher := -- My god I hate regular expressions, they're such unreadable nonsense Pat.Compile ("{{(?:(?:\w|\s)+:)?((?:\w|\s)+)}}", Pat.Single_Line); Marker : Positive := Raw_Data'First; begin loop Pat.Match (Regexp, Raw_Data, Matches, Marker); exit when Matches (1) = Pat.No_Match; declare Item : String := Raw_Data (Matches (1).First .. Matches (1).Last); begin if Item /= "FrontSide" then FIDs.Append (Field_ID (+Item)); end if; end; Marker := Matches (0).Last + 1; end loop; end Regex_Fields; procedure Extract_Templates (Value : in JS.JSON_Array; TMPLs : out Template_Vector) is Index : Positive; Item : JS.JSON_Value; Current_Tmpl : Template; begin Index := JS.Array_First (Value); while JS.Array_Has_Element (Value, Index) loop Item := JS.Array_Element (Value, Index); Regex_Fields (JS.Get (Item, "qfmt"), Current_Tmpl.Question); Regex_Fields (JS.Get (Item, "afmt"), Current_Tmpl.Answer); TMPLs.Append (Current_Tmpl); Current_Tmpl.Question.Clear; Current_Tmpl.Answer.Clear; Index := Index + 1; end loop; end Extract_Templates; procedure Extract_Model (Name : in JS.UTF8_String; Value : in JS.JSON_Value; Models : in out Model_Map) is Current_Model : Model; begin Extract_Field_IDs (JS.Get (Value, "flds"), Current_Model.Fields); Extract_Templates (JS.Get (Value, "tmpls"), Current_Model.Templates); Models.Insert (Model_ID (+Name), Current_Model); end Extract_Model; procedure Query_Models (Deck : in out Deck_Handle; Models : out Model_Map) is Statement : SQLite3.SQLite3_Statement; Raw_Data : SU.Unbounded_String; JSON_Data : JS.JSON_Value; procedure JSON_Callback (Name : in JS.UTF8_String; Value : in JS.JSON_Value) is begin Extract_Model (Name, Value, Models); end JSON_Callback; begin Deck.SQL_Handle.Prepare ("SELECT models FROM col", Statement); Statement.Step; Raw_Data := Statement.Column (0); JSON_Data := JS.Read (-Raw_Data); JS.Map_JSON_Object (JSON_Data, JSON_Callback'Access); end Query_Models; procedure Tokenize_Fields (Raw_Data : in SU.Unbounded_String; Fields : out Field_Vector) is Charset : Strmap.Character_Set := Strmap.To_Set (Latin.US); Position : Positive := 1; Next : Natural := 1; begin while Next /= 0 and Position <= SU.Length (Raw_Data) loop Next := SU.Index (Raw_Data, Charset, Position); if Position <= Next then Fields.Append (Field (SU.Unbounded_Slice (Raw_Data, Position, Next - 1))); else Fields.Append (Field (SU.Unbounded_Slice (Raw_Data, Position, SU.Length (Raw_Data)))); end if; Position := Next + 1; end loop; end Tokenize_Fields; procedure Query_Notes (Deck : in out Deck_Handle; Notes : out Note_Vector) is use type SQLite3.Status_Code; Statement : SQLite3.SQLite3_Statement; Current_Note : Note; Raw_Model : SU.Unbounded_String; begin Deck.SQL_Handle.Prepare ("SELECT mid, flds FROM notes", Statement); loop Statement.Step; exit when Statement.Status /= SQLite3.SQLITE_ROW; Raw_Model := Statement.Column (0); Current_Note.Model := Model_ID (Raw_Model); Tokenize_Fields (Statement.Column (1), Current_Note.Fields); Notes.Append (Current_Note); Current_Note.Fields.Clear; end loop; end Query_Notes; function Compose_Name (Directory : in String; Basename : in String; Extension : in String; Model_Num : in Positive) return SU.Unbounded_String is Result : SU.Unbounded_String := +FD.Compose (Directory, Basename); begin if Model_Num > 1 then SU.Append (Result, "-" & Strfix.Trim (Integer'Image (Model_Num), Ada.Strings.Left)); end if; SU.Append (Result, "." & Extension); return Result; end Compose_Name; function Compose_Dir (Directory : in String; Basename : in String; Model_Num : in Positive) return SU.Unbounded_String is Result : SU.Unbounded_String := +FD.Compose (Directory, Basename); begin if Model_Num > 1 then SU.Append (Result, "-" & Strfix.Trim (Integer'Image (Model_Num), Ada.Strings.Left)); end if; return Result; end Compose_Dir; procedure Extract_Images (Texts : in out Field_Vector; Outdir : in SU.Unbounded_String; Media : in Media_Collection) is use type Pat.Match_Location; Matches : Pat.Match_Array (0 .. 2); Regexp : Pat.Pattern_Matcher := Pat.Compile -- Absolutely disgusting regexes ("", Pat.Single_Line); Marker : Positive; Location : Pat.Match_Location; Match_Name : SU.Unbounded_String; begin for Text of Texts loop Marker := 1; loop Pat.Match (Regexp, -(SU.Unbounded_String (Text)), Matches, Marker); exit when Matches (0) = Pat.No_Match; Location := (if Matches (1) = Pat.No_Match then Matches (2) else Matches (1)); Match_Name := SU.Unbounded_Slice (SU.Unbounded_String (Text), Location.First, Location.Last); if Media.Map.Contains (Media_Name (Match_Name)) then if not FD.Exists (-Outdir) then FD.Create_Directory (-Outdir); end if; if not FD.Exists (FD.Compose (-Outdir, -Match_Name)) then UnZip.Extract (-Media.Filename, SU.To_String (SU.Unbounded_String (Media.Map.Element (Media_Name (Match_Name)))), FD.Compose (-Outdir, -Match_Name)); end if; SU.Insert (SU.Unbounded_String (Text), Location.First, "%%/"); end if; Marker := Matches (0).Last + 1; end loop; end loop; end Extract_Images; procedure Write_CSV (Directory : in String; Basename : in String; Models : in Model_Map; Notes : in Note_Vector; Overwrite : in Boolean := False) is package My_CSV is new CSV; Counter : Positive := 1; Outname : SU.Unbounded_String; File_Handle : TIO.File_Type; Row_Size : Positive; begin for C in Models.Iterate loop Outname := Compose_Name (Directory, Basename, "csv", Counter); if FD.Exists (-Outname) then if not Overwrite then raise FD.Name_Error; else FD.Delete_File (-Outname); end if; end if; TIO.Create (File_Handle, TIO.Out_File, -Outname); Row_Size := Positive (Model_Maps.Element (C).Fields.Length); My_CSV.Put_Header (File_Handle, Model_Maps.Element (C).Fields); for N of Notes loop if N.Model = Model_Maps.Key (C) then My_CSV.Put_Row (File_Handle, N.Fields, Row_Size); end if; end loop; TIO.Close (File_Handle); Counter := Counter + 1; end loop; end Write_CSV; procedure Write_FMD (Directory : in String; Basename : in String; Models : in Model_Map; Notes : in Note_Vector; Media : in Media_Collection; Overwrite : in Boolean := False) is Counter : Positive := 1; Outname, Outdir : SU.Unbounded_String; File_Handle : TIO.File_Type; Current_Entry : Field_Vector; Entry_Size : Positive; begin for C in Models.Iterate loop Outname := Compose_Name (Directory, Basename, "fmd", Counter); Outdir := Compose_Dir (Directory, Basename, Counter); if FD.Exists (-Outname) then if not Overwrite then raise FD.Name_Error with "output file " & (-Outname) & " already exists"; else FD.Delete_File (-Outname); end if; end if; if FD.Exists (-Outdir) and not Overwrite then raise FD.Name_Error with "media directory " & (-Outdir) & " already exists"; end if; TIO.Create (File_Handle, TIO.Out_File, -Outname); Entry_Size := Positive (Model_Maps.Element (C).Fields.Length); FMD.Put_Header (File_Handle); FMD.Put_Fields (File_Handle, Model_Maps.Element (C).Fields); FMD.Start_Pack_Section (File_Handle); for Tmpl of Model_Maps.Element (C).Templates loop FMD.Put_Pack (File_Handle, Tmpl.Question, Tmpl.Answer); end loop; FMD.End_Pack_Section (File_Handle); FMD.Start_Entry_Section (File_Handle); for N of Notes loop if N.Model = Model_Maps.Key (C) then Current_Entry := N.Fields; Extract_Images (Current_Entry, Outdir, Media); FMD.Put_Entry (File_Handle, Current_Entry, Entry_Size); end if; end loop; FMD.End_Entry_Section (File_Handle); FMD.Put_Footer (File_Handle); TIO.Close (File_Handle); Counter := Counter + 1; end loop; end Write_FMD; end Deckdata.IO;