-- -- -- package Copyright (c) Dmitry A. Kazakov -- -- Gtk.Widget.Styles.CSS_Store Luebeck -- -- Implementation Spring, 2013 -- -- -- -- Last revision : 12:32 10 Jun 2003 -- -- -- -- This library is free software; you can redistribute it and/or -- -- modify it under the terms of the GNU General Public License as -- -- published by the Free Software Foundation; either version 2 of -- -- the License, or (at your option) any later version. This library -- -- 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 library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from -- -- this unit, or you link this unit with other files to produce an -- -- executable, this unit does not by itself cause the resulting -- -- executable to be covered by the GNU General Public License. This -- -- exception does not however invalidate any other reasons why the -- -- executable file might be covered by the GNU Public License. -- --____________________________________________________________________-- with Gdk.Color; use Gdk.Color; with Gtk.Container; use Gtk.Container; with Gtk.Missed; use Gtk.Missed; with Gtk.Style; use Gtk.Style; with GLib.Properties.Creation; use GLib.Properties.Creation; with System; use System; with System.Address_To_Access_Conversions; package body Gtk.Widget.Styles.CSS_Store is function Style_Get ( Widget : access Gtk_Widget_Record'Class; Property_Name : UTF8_String ) return Gtk_Border is package Conversions is new System.Address_To_Access_Conversions (Gtk_Border); use Conversions; Result : Gtk_Border; Value : GValue; Ptr : Address; begin Init (Value, Border_Get_Type); Style_Get_Property (Widget, Property_Name, Value); Ptr := Get_Boxed (Value); if Ptr = Null_Address then Unset (Value); raise Constraint_Error; else Result := To_Pointer (Ptr).all; Unset (Value); return Result; end if; -- procedure Internal -- ( Widget : System.Address; -- Property_Name : Property; -- Border : out Gtk_Border_Ptr; -- Terminator : System.Address := System.Null_Address -- ); -- pragma Import (C, Internal, "gtk_widget_style_get"); -- procedure G_Free (Border : Gtk_Border_Ptr); -- pragma Import (C, G_Free, "g_free"); -- Ptr : Gtk_Border_Ptr; -- Result : Gtk_Border; -- begin -- Internal (Get_Object (Widget), Build (Property_Name), Ptr); -- if Ptr = null then -- raise Constraint_Error; -- else -- Result := Ptr.all; -- G_Free (Ptr); -- return Result; -- end if; end Style_Get; procedure Put ( File : File_Type; Widget : access Gtk_Widget_Record'Class; Recurse : Boolean; Prefix : String ) is Figure : constant array (0..15) of Character := "0123456789ABCDEF"; procedure Put_String (Text : String) is Value : Integer; begin Put (File, '"'); for Index in Text'Range loop Value := Character'Pos (Text (Index)); if Text (Index) = '\' or else Value in 16#00#..16#1F# then Put (File, "\"); Put (File, Figure (Value / 64)); Value := Value / 8; Put (File, Figure (Value / 8)); Value := Value / 8; Put (File, Figure (Value)); else Put (File, Text (Index)); end if; end loop; Put (File, '"'); end Put_String; procedure Put_Flags ( Class_Of : Flags_Class; Mask : GLong ) is Flag : Flags_Value; First : Boolean := True; begin for Index in 0..GUInt'Last loop Flag := Nth_Value (Class_Of, Index); exit when Flag = null; if 0 /= (Value (Flag) and Flags_Int_Value (Mask)) then if First then First := False; else Put (File, "| "); end if; Put ( File, GLib.Properties.Creation.Name (Flag) ); end if; end loop; end Put_Flags; function Get_Prefix return String is begin if Prefix'Length = 0 then return Get_Name (Widget); else return Prefix & "->" & Get_Name (Widget); end if; end Get_Prefix; New_Prefix : constant String := Get_Prefix; begin if Recurse and then Widget.all in Gtk_Container_Record'Class then declare use Widget_List; Children : Widget_List.GList := Get_Children ( Gtk_Container_Record'Class (Widget.all)'Access ); Child : Widget_List.GList := First (Children); begin while Child /= Null_List loop Put (File, Get_Data (Child), Recurse, New_Prefix); Child := Next (Child); end loop; Free (Children); exception when others => Free (Children); raise; end; end if; declare Class_Name : constant String := Type_Name (Get_Type (Widget)); Class : constant GObject_Class := Gtk.Missed.Class_From_Type (Get_Type (Widget)); List : constant Param_Spec_Array := Class_List_Style_Properties (Class); begin Put_Line ( File, Class_Name & '#' & Get_Name (Widget) ); Put_Line (File, "{ /* " & New_Prefix & " */"); for Index in List'Range loop declare Param : constant Param_Spec := List (Index); Name : constant String := PSpec_Name (Param); Param_Type : constant GType := Value_Type (Param); begin Put_Line ( File, " /* " & Description (Param) & " */" ); Put (File, " /* " & Type_Name (Param_Type)); if Param_Type = GType_String then declare This : constant Param_Spec_String := Param_Spec_String (Param); Value : constant String := Style_Get (Widget, Name); begin Put (File, " Default is "); Put_String (Default (This)); Put (File, " */"); New_Line (File); Put ( File, " -" & Class_Name & "-" & Name & ": " ); Put_String (Value); Put (File, ";"); New_Line (File); end; elsif Param_Type = GType_Char then declare This : constant Param_Spec_Char := Param_Spec_Char (Param); Value : constant GChar := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GInt8'Image (Minimum (This)) & " .." & GInt8'Image (Maximum (This)) & " Default is" & GInt8'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & Integer'Image (GChar'Pos (Value)) & ";" ) ); end; elsif Param_Type = GType_Double then declare This : constant Param_Spec_Double := Param_Spec_Double (Param); Value : constant GDouble := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GDouble'Image (Minimum (This)) & " .." & GDouble'Image (Maximum (This)) & " Default is" & GDouble'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GDouble'Image (Value) & ";" ) ); end; elsif Param_Type = GType_Float then declare This : constant Param_Spec_Float := Param_Spec_Float (Param); Value : constant GFloat := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GFloat'Image (Minimum (This)) & " .." & GFloat'Image (Maximum (This)) & " Default is" & GFloat'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GFloat'Image (Value) & ";" ) ); end; elsif Param_Type = GType_Long then declare This : constant Param_Spec_Long := Param_Spec_Long (Param); Value : constant GLong := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GLong'Image (Minimum (This)) & " .." & GLong'Image (Maximum (This)) & " Default is" & GLong'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GLong'Image (Value) & ";" ) ); end; elsif Param_Type = GType_Int then declare This : constant Param_Spec_Int := Param_Spec_Int (Param); Value : constant GInt := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GInt'Image (Minimum (This)) & " .." & GInt'Image (Maximum (This)) & " Default is" & GInt'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GInt'Image (Value) & ";" ) ); end; elsif Param_Type = GType_UChar then declare This : constant Param_Spec_UChar := Param_Spec_UChar (Param); Value : constant GUChar := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GUInt8'Image (Minimum (This)) & " .." & GUInt8'Image (Maximum (This)) & " Default is" & GUInt8'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & Integer'Image (GUChar'Pos (Value)) & ";" ) ); end; elsif Param_Type = GType_UInt then declare This : constant Param_Spec_UInt := Param_Spec_UInt (Param); Value : constant GUInt := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GUInt'Image (Minimum (This)) & " .." & GUInt'Image (Maximum (This)) & " Default is" & GUInt'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GUInt'Image (Value) & ";" ) ); end; elsif Param_Type = GType_ULong then declare This : constant Param_Spec_ULong := Param_Spec_ULong (Param); Value : constant GULong := Style_Get (Widget, Name); begin Put_Line ( File, ( " range " & GULong'Image (Minimum (This)) & " .." & GULong'Image (Maximum (This)) & " Default is" & GULong'Image (Default (This)) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GULong'Image (Value) & ";" ) ); end; elsif Param_Type = GType_Boolean then declare This : constant Param_Spec_Boolean := Param_Spec_Boolean (Param); Value : constant Boolean := Style_Get (Widget, Name); begin Put_Line ( File, ( " Default is" & Integer'Image (Boolean'Pos (Default (This))) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & Integer'Image (Boolean'Pos (Value)) & ";" ) ); end; elsif Param_Type = Gdk_Color_Type then declare Value : Gdk_Color; Default : Gdk_Color; begin Put (File, " */"); New_Line (File); Set_RGB (Default, 0, 0, 0); Value := Style_Get (Widget, Name, Default); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ": #" & Figure (Integer (Red (Value) / (256 * 16))) & Figure (Integer (Red (Value) rem 16)) & Figure (Integer (Green (Value) / (256 * 16))) & Figure (Integer (Green (Value) rem 16)) & Figure (Integer (Blue (Value) / (256 * 16))) & Figure (Integer (Blue (Value) rem 16)) & ";" ) ); end; elsif Is_A (Param_Type, GType_Enum) then declare This : constant Param_Spec_Enum := Param_Spec_Enum (Param); Value : Enum_Value; First : Boolean := True; Class_Of : constant Enum_Class := Enumeration (This); begin Put (File, " ("); for Index in 0..GUInt'Last loop Value := Nth_Value (Class_Of, Index); exit when Value = null; if First then First := False; else Put (File, ", "); end if; Put ( File, GLib.Properties.Creation.Name (Value) ); end loop; Put_Line ( File, ( ") Default is " & GLib.Properties.Creation.Name ( Get_Value ( Class_Of, Default (This) ) ) & " */" ) ); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ":" & GLib.Properties.Creation.Name ( Get_Value ( Class_Of, Style_Get (Widget, Name) ) ) & ";" ) ); end; elsif Is_A (Param_Type, GType_Flags) then declare This : constant Param_Spec_Flags := Param_Spec_Flags (Param); Class_Of : constant Flags_Class := Flags_Enumeration (This); Value : Flags_Value; First : Boolean := True; begin Put (File, " ("); for Index in 0..GUInt'Last loop Value := Nth_Value (Class_Of, Index); exit when Value = null; if First then First := False; else Put (File, "or "); end if; Put ( File, GLib.Properties.Creation.Name (Value) ); end loop; Put_Line (File, ") Default is "); Put_Flags (Class_Of, Default (This)); Put (File, " */"); New_Line (File); Put ( File, " -" & Class_Name & "-" & Name & ": " ); Put_Flags (Class_Of, Style_Get (Widget, Name)); Put (File, ";"); New_Line (File); end; elsif Param_Type = Border_Get_Type then Put (File, " */"); New_Line (File); declare Border : Gtk_Border; begin Border := Style_Get (Widget, Name); Put_Line ( File, ( " -" & Class_Name & "-" & Name & ": " & GInt16'Image (Border.Left) & " " & GInt16'Image (Border.Right) & " " & GInt16'Image (Border.Top) & " " & GInt16'Image (Border.Bottom) & ";" ) ); exception when Constraint_Error => Put_Line ( File, ( " -" & Class_Name & "-" & Name & ": 1 1 1 1; /* Undefined */" ) ); end; else Put (File, " */"); New_Line (File); Put_Line ( File, "/***" & Name & ": the type is not supported */" ); end if; end; end loop; end; Put_Line (File, "}"); end Put; procedure Put_CSS_Styles ( File : File_Type; Widget : not null access Gtk_Widget_Record'Class; Recurse : Boolean := True ) is begin Put (File, Widget, Recurse, ""); end Put_CSS_Styles; procedure Put_CSS_Styles ( Widget : not null access Gtk_Widget_Record'Class; Recurse : Boolean := True ) is begin Put (Standard_Output, Widget, Recurse, ""); end Put_CSS_Styles; end Gtk.Widget.Styles.CSS_Store;