--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+open Pxp_types
+open Pxp_document
+open Pxp_yacc
+
+let empty_record = new element_impl (Pxp_yacc.default_extension);;
+let empty_dnode = new data_impl Pxp_yacc.default_extension;;
+
+class context the_filename the_obj_dtd the_index the_root the_topframe =
+ object (self)
+ val filename = the_filename
+ val obj_dtd = the_obj_dtd
+ val node_index = the_index
+ val mutable obj = empty_record # create_element
+ the_obj_dtd (T_element "record") []
+ val root = the_root
+ val topframe = the_topframe
+ val mutable wdg = None
+
+ val mutable history = ( [| |] : string array )
+ val mutable index = 0
+
+ initializer
+ self # load_obj
+
+ method obj = obj
+
+ (* history *)
+
+ method private leave_node =
+ begin match wdg with
+ None -> ()
+ | Some w -> Tk.destroy w
+ end;
+ wdg <- None
+
+ method private enter_node =
+ let where = history.(index) in
+ let n =
+ try node_index # find where with
+ Not_found -> failwith ("Mask not found: " ^ where) in
+ let w = n # extension # create_widget topframe self in
+ Tk.pack [w] (n # extension # pack_opts @ [ Tk.Expand true] );
+ wdg <- Some w
+
+
+
+ method previous =
+ if index > 0 then
+ index <- index - 1
+ else
+ raise Not_found;
+ self # leave_node;
+ self # enter_node;
+
+
+ method next =
+ if index < Array.length history - 1 then
+ index <- index + 1
+ else
+ raise Not_found;
+ self # leave_node;
+ self # enter_node;
+
+
+ method goto where =
+ assert (index <= Array.length history);
+ self # leave_node;
+ let persisting_history =
+ if index < Array.length history then
+ Array.sub history 0 (index+1)
+ else
+ history
+ in
+ history <- Array.concat [ persisting_history; [| where |] ];
+ index <- Array.length history - 1;
+ self # enter_node;
+
+
+ method current =
+ if index < Array.length history then
+ history.(index)
+ else
+ raise Not_found
+
+
+ (* read, write the slots of object *)
+
+ method search_slot name =
+ let rec search n =
+ match n # node_type with
+ T_element "string" ->
+ if n # required_string_attribute "name" = name then
+ n
+ else raise Not_found
+ | T_element _ ->
+ search_list (n # sub_nodes)
+ | T_data ->
+ raise Not_found
+ | _ ->
+ assert false
+
+ and search_list l =
+ match l with
+ x :: l' ->
+ (try search x with Not_found -> search_list l')
+ | [] ->
+ raise Not_found
+ in
+ search obj
+
+ method get_slot name =
+ let d = (self # search_slot name) # data in
+ d
+
+ method set_slot name value =
+ let dtd = obj # dtd in
+ begin try
+ let n = self # search_slot name in
+ n # delete
+ with
+ Not_found -> ()
+ end;
+ let e_string = empty_record # create_element dtd (T_element "string")
+ [ "name", name ] in
+ let dnode = empty_dnode # create_data dtd value in
+ e_string # add_node dnode;
+ e_string # local_validate();
+ obj # add_node e_string;
+ assert(self # get_slot name = value)
+
+ (* load, save object *)
+
+
+ method load_obj =
+ if Sys.file_exists filename then begin
+ obj <- parse_content_entity
+ default_config
+ (from_file filename)
+ obj_dtd
+ default_spec
+ end
+ else begin
+ print_string "New file!\n";
+ flush stdout
+ end
+
+
+ method save_obj =
+ let fd = open_out filename in
+ try
+
+ let re1 = Str.regexp "&" in
+ let re2 = Str.regexp "<" in
+ let re3 = Str.regexp "'" in
+ let re4 = Str.regexp ">" in
+ let protect s =
+ let s1 = Str.global_replace re1 "&" s in
+ let s2 = Str.global_replace re2 "<" s1 in
+ let s3 = Str.global_replace re3 "'" s2 in
+ let s4 = Str.global_replace re2 ">" s1 in
+ s3
+ in
+
+ let rec iterate (n : 'node extension node as 'node) =
+ match n # node_type with
+ T_data ->
+ output_string fd (protect (n # data))
+ | T_element name ->
+ output_string fd ("<" ^ name ^ "\n");
+ let anames = n # attribute_names in
+ List.iter
+ (fun aname ->
+ let aval = n # attribute aname in
+ let v =
+ match aval with
+ Value s ->
+ aname ^ "='" ^ protect s ^ "'\n"
+ | Valuelist l ->
+ aname ^ "='" ^ String.concat " " (List.map protect l) ^ "'\n"
+ | Implied_value ->
+ ""
+ in
+ output_string fd v)
+ anames;
+ output_string fd ">";
+ List.iter iterate (n # sub_nodes);
+ output_string fd ("</" ^ name ^ "\n>");
+ | _ ->
+ assert false
+ in
+
+ output_string fd "<?xml version='1.0' encoding='ISO-8859-1'?>\n";
+ iterate obj;
+ close_out fd
+ with
+ e ->
+ close_out fd;
+ raise e
+
+ end
+;;
+
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:31 lpadovan
+ * Initial revision
+ *
+ * Revision 1.7 2000/08/30 15:58:49 gerd
+ * Updated.
+ *
+ * Revision 1.6 2000/07/23 20:25:05 gerd
+ * Update because of API change: local_validate.
+ *
+ * Revision 1.5 2000/07/16 19:36:03 gerd
+ * Updated.
+ *
+ * Revision 1.4 2000/07/08 22:03:11 gerd
+ * Updates because of PXP interface changes.
+ *
+ * Revision 1.3 2000/06/04 20:29:19 gerd
+ * Updates because of renamed PXP modules.
+ *
+ * Revision 1.2 2000/05/30 00:09:08 gerd
+ * Minor fix.
+ *
+ * Revision 1.1 1999/08/21 19:11:05 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff