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