helm/DEVEL/pxp/pxp/examples/xmlforms/ds_context.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6 open Pxp_types
   7 open Pxp_document
   8 open Pxp_yacc
   9
  10 let empty_record = new element_impl (Pxp_yacc.default_extension);;
  11 let empty_dnode = new data_impl Pxp_yacc.default_extension;;
  12
  13 class context the_filename the_obj_dtd the_index the_root the_topframe =
  14   object (self)
  15     val filename = the_filename
  16     val obj_dtd = the_obj_dtd
  17     val node_index = the_index
  18     val mutable obj = empty_record # create_element
  19                         the_obj_dtd (T_element "record") []
  20     val root = the_root
  21     val topframe = the_topframe
  22     val mutable wdg = None
  23
  24     val mutable history = ( [| |] : string array )
  25     val mutable index = 0
  26
  27     initializer
  28       self # load_obj
  29
  30     method obj = obj
  31
  32     (* history *)
  33
  34     method private leave_node =
  35       begin match wdg with
  36           None -> ()
  37         | Some w -> Tk.destroy w
  38       end;
  39       wdg <- None
  40
  41     method private enter_node =
  42       let where = history.(index) in
  43       let n =
  44         try node_index # find where with
  45             Not_found -> failwith ("Mask not found: " ^ where) in
  46       let w = n # extension # create_widget topframe self in
  47       Tk.pack [w] (n # extension # pack_opts @ [ Tk.Expand true] );
  48       wdg <- Some w
  49
  50
  51
  52     method previous =
  53       if index > 0 then
  54         index <- index - 1
  55       else
  56         raise Not_found;
  57       self # leave_node;
  58       self # enter_node;
  59
  60
  61     method next =
  62       if index < Array.length history - 1 then
  63         index <- index + 1
  64       else
  65         raise Not_found;
  66       self # leave_node;
  67       self # enter_node;
  68
  69
  70     method goto where =
  71       assert (index <= Array.length history);
  72       self # leave_node;
  73       let persisting_history =
  74         if index < Array.length history then
  75           Array.sub history 0 (index+1)
  76         else
  77           history
  78       in
  79       history <- Array.concat [ persisting_history; [| where |] ];
  80       index <- Array.length history - 1;
  81       self # enter_node;
  82
  83
  84     method current =
  85       if index < Array.length history then
  86         history.(index)
  87       else
  88         raise Not_found
  89
  90
  91     (* read, write the slots of object *)
  92
  93     method search_slot name =
  94       let rec search n =
  95         match n # node_type with
  96             T_element "string" ->
  97               if n # required_string_attribute "name" = name then
  98                 n
  99               else raise Not_found
 100           | T_element _ ->
 101               search_list (n # sub_nodes)
 102           | T_data ->
 103               raise Not_found
 104           | _ ->
 105               assert false
 106
 107        and search_list l =
 108          match l with
 109              x :: l' ->
 110                (try search x with Not_found -> search_list l')
 111            | [] ->
 112                raise Not_found
 113       in
 114       search obj
 115
 116     method get_slot name =
 117       let d = (self # search_slot name) # data in
 118       d
 119
 120     method set_slot name value =
 121       let dtd = obj # dtd in
 122       begin try
 123         let n = self # search_slot name in
 124         n # delete
 125       with
 126           Not_found -> ()
 127       end;
 128       let e_string = empty_record # create_element dtd (T_element "string")
 129                 [ "name", name ] in
 130       let dnode = empty_dnode # create_data dtd value in
 131       e_string # add_node dnode;
 132       e_string # local_validate();
 133       obj # add_node e_string;
 134       assert(self # get_slot name = value)
 135
 136     (* load, save object *)
 137
 138
 139     method load_obj =
 140       if Sys.file_exists filename then begin
 141         obj <- parse_content_entity
 142           default_config
 143           (from_file filename)
 144           obj_dtd
 145           default_spec
 146       end
 147       else begin
 148         print_string "New file!\n";
 149         flush stdout
 150       end
 151
 152
 153     method save_obj =
 154       let fd = open_out filename in
 155       try
 156
 157         let re1 = Str.regexp "&" in
 158         let re2 = Str.regexp "<" in
 159         let re3 = Str.regexp "'" in
 160         let re4 = Str.regexp ">" in
 161         let protect s =
 162           let s1 = Str.global_replace re1 "&amp;" s in
 163           let s2 = Str.global_replace re2 "&lt;" s1 in
 164           let s3 = Str.global_replace re3 "&apos;" s2 in
 165           let s4 = Str.global_replace re2 "&gt;" s1 in
 166           s3
 167         in
 168
 169         let rec iterate (n : 'node extension node as 'node) =
 170           match n # node_type with
 171               T_data ->
 172                 output_string fd (protect (n # data))
 173             | T_element name ->
 174                 output_string fd ("<" ^ name ^ "\n");
 175                 let anames = n # attribute_names in
 176                 List.iter
 177                   (fun aname ->
 178                      let aval = n # attribute aname in
 179                      let v =
 180                        match aval with
 181                            Value s ->
 182                              aname ^ "='" ^ protect s ^ "'\n"
 183                          | Valuelist l ->
 184                              aname ^ "='" ^ String.concat " " (List.map protect l) ^ "'\n"
 185                          | Implied_value ->
 186                              ""
 187                      in
 188                      output_string fd v)
 189                   anames;
 190                 output_string fd ">";
 191                 List.iter iterate (n # sub_nodes);
 192                 output_string fd ("</" ^ name ^ "\n>");
 193             | _ ->
 194                 assert false
 195         in
 196
 197         output_string fd "<?xml version='1.0' encoding='ISO-8859-1'?>\n";
 198         iterate obj;
 199         close_out fd
 200       with
 201           e ->
 202             close_out fd;
 203             raise e
 204
 205   end
 206 ;;
 207
 208
 209 (* ======================================================================
 210  * History:
 211  *
 212  * $Log$
 213  * Revision 1.1  2000/11/17 09:57:31  lpadovan
 214  * Initial revision
 215  *
 216  * Revision 1.7  2000/08/30 15:58:49  gerd
 217  *      Updated.
 218  *
 219  * Revision 1.6  2000/07/23 20:25:05  gerd
 220  *      Update because of API change: local_validate.
 221  *
 222  * Revision 1.5  2000/07/16 19:36:03  gerd
 223  *      Updated.
 224  *
 225  * Revision 1.4  2000/07/08 22:03:11  gerd
 226  *      Updates because of PXP interface changes.
 227  *
 228  * Revision 1.3  2000/06/04 20:29:19  gerd
 229  *      Updates because of renamed PXP modules.
 230  *
 231  * Revision 1.2  2000/05/30 00:09:08  gerd
 232  *      Minor fix.
 233  *
 234  * Revision 1.1  1999/08/21 19:11:05  gerd
 235  *      Initial revision.
 236  *
 237  *
 238  *)