open Rss
module C = Configwin
let map_opt f = function None -> None | Some v -> Some (f v)
let string_of_opt = function
None -> ""
| Some s -> s
let opt_of_string = function
"" -> None
| s -> Some s
let copy_item i = { i with item_title = i.item_title }
let tuple_to_date (d,m,y) =
{ year = y;
month = m + 1;
day = d ;
hour = 12 ;
minute = 0 ;
second = 0 ;
zone = 0;
week_day = 0 ;
}
let today = Rss.float_to_date (Unix.time())
let date_to_tuple d = (d.day, d.month - 1, d.year)
let find_first_child store it =
let p = store#get_path it in
let res = ref None in
store#foreach
(fun _ it ->
let parent = store#iter_parent it in
match parent with
None -> false
| Some itp ->
if store#get_path itp = p then (res := Some it; true) else false
);
!res
let dir = ref (Sys.getcwd ())
let find_iter_above store it =
let p = store#get_path it in
let res = ref None in
store#foreach
(fun path it ->
let rr = store#get_row_reference path in
store#iter_next it;
if store#get_path it = p then (res := Some rr; true) else false
);
!res
let find_iter_below store it =
if store#iter_next it then
Some (store#get_row_reference (store#get_path it))
else
None
let clipboard = ref (None : Rss.item option)
let to_u8 s =
try Glib.Convert.locale_to_utf8 s
with Glib.Convert.Error (_,err) ->
prerr_endline err;
s
let of_u8 = Glib.Convert.locale_from_utf8
let params_for_channel ch =
let ptitle = C.string
~help: "Mandatory title"
~f: (fun s -> ch.ch_title <- of_u8 s)
"Title:" (to_u8 ch.ch_title)
in
let plink = C.string
~help: "Mandatory link"
~f: (fun s -> ch.ch_link <- of_u8 s)
"Link:" (to_u8 ch.ch_link)
in
let pdesc = C.text
~help: "Mandatory description"
~f: (fun s -> ch.ch_desc <- of_u8 s)
"Description:" (to_u8 ch.ch_desc)
in
let plang = C.string
~f: (fun s -> ch.ch_language <- opt_of_string (of_u8 s))
"Language:" (to_u8 (string_of_opt ch.ch_language))
in
let pcopyr = C.text
~help: "Optional copyright note"
~f: (fun s -> ch.ch_copyright <- opt_of_string (of_u8 s))
"Copyright:" (to_u8 (string_of_opt ch.ch_copyright))
in
let pmngedit = C.string
~help: "Optional email of managing editor"
~f: (fun s -> ch.ch_managing_editor <- opt_of_string (of_u8 s))
"Managing editor:" (to_u8 (string_of_opt ch.ch_managing_editor))
in
let pwebmaster = C.string
~help: "Optional email of webmaster"
~f: (fun s -> ch.ch_webmaster <- opt_of_string (of_u8 s))
"Webmaster" (to_u8 (string_of_opt ch.ch_managing_editor))
in
let ppubdate = C.date
~help: "Publication date of the channel"
~f: (fun d -> ch.ch_pubdate <- Some (tuple_to_date d))
"Pubdate:"
(match ch.ch_pubdate with
None -> date_to_tuple today
| Some d -> date_to_tuple d
)
in
let pdocs = C.string
~help: "An optional url to a RSS reference"
~f: (fun s -> ch.ch_docs <- opt_of_string (of_u8 s))
"Docs:" (to_u8 (string_of_opt ch.ch_docs))
in
let pttl = C.string
~help: "Time to live, in minutes"
~f: (fun s -> ch.ch_ttl <- try map_opt int_of_string (opt_of_string (of_u8 s)) with _ -> ch.ch_ttl)
"Time to live:" (to_u8 (string_of_opt (map_opt string_of_int ch.ch_ttl)))
in
[ C.Section ("Mandatory information",
[ ptitle ; plink ; pdesc ;]) ;
C.Section ("Other information",
[
plang ;
pcopyr ;
pmngedit ;
pwebmaster ;
ppubdate ;
pdocs ;
pttl ;
] );
]
let software = "OCaml-RSS / RSSgui"
let software_author = "Maxence Guesdon"
let software_author_mail = "Maxence.Guesdon@inria.fr"
let software_copyright =
"Copyright 2004 Institut National de Recherche en \n"^
"Informatique et en Automatique. All rights reserved.\n"^
"This software is distributed under the terms of the\n"^
"GNU General Public License version2.\n"^
"(see file LICENSE in the distribution)"
let software_about =
software^" version "^Cam_installation.software_version^"\n\n"^
software_author^"\n"^
software_author_mail^"\n\n"^
software_copyright
let glade_file = Filename.concat Cam_installation.glade_dir "rssgui.glade"
class file wlabel filename_opt =
let cols = new GTree.column_list in
let col_date = cols#add Gobject.Data.string in
let col_title = cols#add Gobject.Data.string in
let col_author = cols#add Gobject.Data.string in
let (col_data: Rss.item GTree.column) = cols#add Gobject.Data.caml in
let store = GTree.list_store cols in
object(self)
inherit Rss_gui_base.file ~file: glade_file ()
val mutable filename = filename_opt
val mutable channel =
Rss.channel ~title: "Title" ~link: "http://foo.fr" ~desc: "Description" []
method filename = filename
method save () =
match filename with
None -> self#save_as ()
| Some f ->
let channel = self#build_channel () in
try Rss.print_file f channel
with
Sys_error s
| Failure s ->
GToolbox.message_box "Error" s;
self#save_as ()
method save_as () =
match GToolbox.select_file ~title: "Open file" ~dir () with
None -> ()
| Some f ->
filename <- Some f;
wlabel#set_text (Filename.basename f);
self#save ()
method close () = true
method delete ?(cut=false) () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
let item = copy_item (store#get ~row ~column: col_data) in
if cut then clipboard := Some item;
ignore (store#remove rr#iter) ;
tv#selection#unselect_all ()
method copy () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
let item = copy_item (store#get ~row ~column: col_data) in
clipboard := Some item
method paste () =
match !clipboard with
None -> ()
| Some item ->
self#insert_item (copy_item item) ;
tv#selection#unselect_all ()
method move_up () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match find_iter_above store row with
None -> ()
| Some rr2 ->
let it1 = store#get_iter rr#path in
let it2 = rr2#iter in
ignore (store#swap it1 it2)
method move_down () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match find_iter_below store row with
None -> ()
| Some rr2 ->
let it1 = store#get_iter rr#path in
let it2 = rr2#iter in
ignore (store#swap it1 it2)
method selected_rr =
match tv#selection#get_selected_rows with
| [] -> None
| path :: _ -> Some (store#get_row_reference path)
method private params_for_item item =
let param_title = C.string
~f: (fun s -> item.item_title <- opt_of_string (of_u8 s))
"Title:" (to_u8 (string_of_opt item.item_title))
in
let param_link = C.string
~f: (fun s -> item.item_link <- opt_of_string (of_u8 s))
"Link:" (to_u8 (string_of_opt item.item_link))
in
let param_author = C.string
~f: (fun s -> item.item_author <- opt_of_string (of_u8 s))
"Author's mail:" (to_u8 (string_of_opt item.item_author))
in
let param_pubdate = C.date
~f: (fun d -> item.item_pubdate <- Some (tuple_to_date d))
"Pubdate:"
(match item.item_pubdate with
None -> date_to_tuple today
| Some d -> date_to_tuple d
)
in
let param_desc = C.text
~f: (fun s -> item.item_desc <- opt_of_string (of_u8 s))
"Description" (to_u8 (string_of_opt item.item_desc))
in
let param_comments = C.string
~help: "Url of comments about this item"
~f: (fun s -> item.item_comments <- opt_of_string (of_u8 s))
"Comments:" (to_u8 (string_of_opt item.item_comments))
in
[param_title ; param_link ; param_author ; param_pubdate ; param_desc ; param_comments ]
method add_item () =
let i = Rss.item ~pubdate: today () in
match C.simple_get ~width: 500 "Add item"
(self#params_for_item i)
with
C.Return_ok -> self#insert_item i
| _ -> ()
method edit_selected () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
let item = store#get ~row ~column: col_data in
let params = self#params_for_item item in
match C.simple_get ~width: 500 "Edit item" params with
C.Return_ok -> self#display_item row item
| _ -> ()
method edit_channel () =
let sections = params_for_channel channel in
ignore (C.edit "Edit channel" ~height: 400 ~width: 500 sections)
method display_item row item =
let sdate =
match item.item_pubdate with
None -> "" |
Some d -> Rss.string_of_date d
in
store#set ~row ~column: col_date (to_u8 sdate);
store#set ~row ~column: col_title (to_u8 (string_of_opt item.item_title));
store#set ~row ~column: col_author (to_u8 (string_of_opt item.item_author))
method insert_item item =
let row = store#append () in
store#set ~row ~column: col_data item;
self#display_item row item
method show_channel ch =
store#clear ();
channel <- ch;
List.iter self#insert_item ch.ch_items
method build_channel () =
{ channel with
ch_items = self#build_item_list ();
}
method get_children (it_opt : Gtk.tree_iter option) =
let first =
match it_opt with
None -> store#get_iter_first
| Some it ->
if store#iter_has_child it then
find_first_child store it
else
None
in
match first with
None -> []
| Some it ->
let rr it = store#get_row_reference (store#get_path it) in
let rec f acc it =
if store#iter_next it then
f (rr it :: acc) it
else
List.rev acc
in
f [rr it] it
method build_item_list () =
let rec build rr =
let it = rr#iter in
copy_item (store#get ~row: it ~column: col_data)
in
List.map build (self#get_children None)
method load file =
try
channel <- Rss.channel_of_file file ;
self#show_channel channel
with
Failure s ->
GToolbox.message_box ~title: "Error" s
| Xml.File_not_found _ ->
self#edit_channel ();
self#show_channel channel
| Xml.Error e ->
failwith (Printf.sprintf "Error while loading %s:\n%s" file
(Xml.error e))
initializer
tv#set_model (Some (store :> GTree.model));
let col = GTree.view_column () ~title: "Pubdate"
~renderer:(GTree.cell_renderer_text [], ["text", col_date]) in
ignore (tv#append_column col);
let col = GTree.view_column () ~title: "Title"
~renderer:(GTree.cell_renderer_text [], ["text", col_title]) in
ignore (tv#append_column col);
let col = GTree.view_column () ~title: "Author's mail"
~renderer:(GTree.cell_renderer_text [], ["text", col_author]) in
ignore (tv#append_column col);
match filename_opt with
None -> ()
| Some filename ->
try self#load filename
with e ->
toplevel#destroy ();
raise e
end
class gui ?(quit_on_destroy=true)
?on_close_file
?(default_file=true) files =
object(self)
inherit Rss_gui_base.gui ~file: glade_file ()
val mutable file_boxes = []
method add_file_box f_opt =
let title =
match f_opt with
None -> "<no name>"
| Some s -> Filename.basename s
in
try
let label = GMisc.label ~text: title () in
let fb = new file label f_opt in
let eb = GBin.event_box () in
fb#reparent eb#coerce;
ignore(notebook#append_page ~tab_label: label#coerce eb#coerce);
file_boxes <- file_boxes @ [fb];
notebook#goto_page ((List.length file_boxes) - 1);
match f_opt with
None -> fb#edit_channel ()
| Some _ -> ()
with
e ->
prerr_endline (Printf.sprintf "Error while adding file %s" title);
raise e
method active_file =
try
let n = notebook#current_page in
Some (List.nth file_boxes n)
with
_ -> None
method quit = toplevel#destroy
method about () =
GToolbox.message_box
"About RSSgui"
software_about
method new_file () = self#add_file_box None
method close_current () =
match self#active_file with
None -> ()
| Some fb ->
if fb#close () then
(
ignore (notebook#remove_page notebook#current_page);
match fb#filename, on_close_file with
None, _
| _, None -> ()
| Some name, Some f -> f name
)
method open_file () =
match GToolbox.select_file ~title: "Open file" ~dir () with
None -> ()
| Some f -> self#add_file_box (Some f)
method on_current f () =
match self#active_file with
None -> ()
| Some fb -> f fb
initializer
(
match files with
[] when default_file ->
begin
try self#add_file_box None
with
Failure s ->
GToolbox.message_box "Error" s
| e ->
GToolbox.message_box "Error" (Printexc.to_string e)
end
| [] -> ()
| _ ->
List.iter
(fun s ->
prerr_endline s;
try self#add_file_box (Some s)
with
Failure s ->
GToolbox.message_box "Error" s
| e ->
GToolbox.message_box "Error"
(Printf.sprintf "Error while opening %s:\n%s"
s
(Printexc.to_string e)
)
)
files
);
let handlers =
[ "on_quit_activate", `Simple self#quit;
"on_about_activate",`Simple self#about;
"on_new_activate", `Simple self#new_file;
"on_open_activate", `Simple self#open_file;
"on_save_activate", `Simple (self#on_current (fun fb -> fb#save ())) ;
"on_save_as_activate", `Simple (self#on_current (fun fb -> fb#save_as ())) ;
"on_close_activate", `Simple self#close_current ;
"on_edit_channel_activate", `Simple (self#on_current (fun fb -> fb#edit_channel ())) ;
"on_add_item_activate", `Simple (self#on_current (fun fb -> fb#add_item ())) ;
"on_edit_selected_item_activate", `Simple (self#on_current (fun fb -> fb#edit_selected ())) ;
"on_cut_activate", `Simple (self#on_current (fun fb -> fb#delete ~cut: true ())) ;
"on_copy_activate", `Simple (self#on_current (fun fb -> fb#copy ())) ;
"on_paste_activate", `Simple (self#on_current (fun fb -> fb#paste ())) ;
"on_delete_activate", `Simple (self#on_current (fun fb -> fb#delete ~cut: false ())) ;
"on_move_up_activate", `Simple (self#on_current (fun fb -> fb#move_up ())) ;
"on_move_down_activate", `Simple (self#on_current (fun fb -> fb#move_down ())) ;
]
in
Glade.bind_handlers ~extra:handlers ~warn:true self#xml;
if quit_on_destroy then
ignore(gui#connect#destroy GMain.Main.quit)
end