X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Fpxp%2Fpxp%2Fexamples%2Fxmlforms%2Fds_context.ml;fp=helm%2FDEVEL%2Fpxp%2Fpxp%2Fexamples%2Fxmlforms%2Fds_context.ml;h=453ca00f0c4a322f2a0d97ef31fbeb1ebbc09c33;hb=c03d2c1fdab8d228cb88aaba5ca0f556318bebc5;hp=0000000000000000000000000000000000000000;hpb=758057e85325f94cd88583feb1fdf6b038e35055;p=helm.git diff --git a/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_context.ml b/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_context.ml new file mode 100644 index 000000000..453ca00f0 --- /dev/null +++ b/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_context.ml @@ -0,0 +1,238 @@ +(* $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 (""); + | _ -> + assert false + in + + output_string fd "\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. + * + * + *)