(* * <COPYRIGHT> * Copyright 2003 Gerd Stolpmann * * <GPL> * This file is part of WTimer. * * WTimer 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. * * WTimer 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 WDialog; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * </> *) (* $Id: filemenu.ml,v 1.3 2003/03/23 11:59:14 gerd Exp $ * ---------------------------------------------------------------------- * *) open Wd_types open Db.Types exception Not_competent let handle dlg db event = let universe = dlg # universe in let env = dlg # environment in let session = dlg # dialog_variable "session" in match event with Button("file-editor") -> (* Better to check permissions here than in prepare_page * of editor: *) let login = User (dlg # string_variable "session.login-user") in let sheet = Instance (dlg # string_variable "session.current-sheet") in if not (Db.Permission.check db sheet login `Read) then raise Db_ac.Types.Permission_denied; !Registry.new_editor universe env session | Button("file-select-user") -> !Registry.new_selectuser universe env session | Button("file-time-travel") -> !Registry.new_timetravel universe env session | Button("file-export") -> !Registry.new_export universe env session | Button("file-admin") -> !Registry.new_admin universe env session | Button("file-logout") -> !Registry.new_startpage universe env | _ -> raise Not_competent ;; (* ====================================================================== * History: * * $Log: filemenu.ml,v $ * Revision 1.3 2003/03/23 11:59:14 gerd * GPL * * Revision 1.2 2003/01/26 23:45:16 gerd * Improved error behaviour. * * Revision 1.1 2002/11/16 12:34:51 gerd * Initial revision * * *)