helm/DEVEL/pxp/pxp/pxp_document.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  * PXP: The polymorphic XML parser for Objective Caml.
   4  * Copyright by Gerd Stolpmann. See LICENSE for details.
   5  *)
   6
   7 open Pxp_types
   8 open Pxp_lexer_types
   9 open Pxp_dtd
  10 open Pxp_aux
  11 open Pxp_dfa
  12
  13
  14 exception Skip
  15
  16 type node_type =
  17     T_element of string
  18   | T_data
  19   | T_super_root
  20   | T_pinstr of string
  21   | T_comment
  22   | T_none
  23   | T_attribute of string
  24   | T_namespace of string
  25 ;;
  26
  27
  28 class type ['node] extension =
  29   object ('self)
  30     method clone : 'self
  31     method node : 'node
  32     method set_node : 'node -> unit
  33   end
  34 ;;
  35
  36
  37 class type [ 'ext ] node =
  38   object ('self)
  39     constraint 'ext = 'ext node #extension
  40     method extension : 'ext
  41     method delete : unit
  42     method parent : 'ext node
  43     method root : 'ext node
  44     method orphaned_clone : 'self
  45     method orphaned_flat_clone : 'self
  46     method add_node : ?force:bool -> 'ext node -> unit
  47     method add_pinstr : proc_instruction -> unit
  48     method pinstr : string -> proc_instruction list
  49     method pinstr_names : string list
  50     method node_position : int
  51     method node_path : int list
  52     method sub_nodes : 'ext node list
  53     method iter_nodes : ('ext node -> unit) -> unit
  54     method iter_nodes_sibl :
  55       ('ext node option -> 'ext node -> 'ext node option -> unit) -> unit
  56     method nth_node : int -> 'ext node
  57     method previous_node : 'ext node
  58     method next_node : 'ext node
  59     method set_nodes : 'ext node list -> unit
  60     method data : string
  61     method node_type : node_type
  62     method position : (string * int * int)
  63     method attribute : string -> att_value
  64     method attribute_names : string list
  65     method attribute_type : string -> att_type
  66     method attributes : (string * Pxp_types.att_value) list
  67     method required_string_attribute : string -> string
  68     method required_list_attribute : string -> string list
  69     method optional_string_attribute : string -> string option
  70     method optional_list_attribute : string -> string list
  71     method id_attribute_name : string
  72     method id_attribute_value : string
  73     method idref_attribute_names : string list
  74     method quick_set_attributes : (string * Pxp_types.att_value) list -> unit
  75     method attributes_as_nodes : 'ext node list
  76     method set_comment : string option -> unit
  77     method comment : string option
  78     method dtd : dtd
  79     method encoding : rep_encoding
  80     method create_element :
  81                    ?position:(string * int * int) ->
  82                    dtd -> node_type -> (string * string) list -> 'ext node
  83     method create_data : dtd -> string -> 'ext node
  84     method local_validate : ?use_dfa:bool -> unit -> unit
  85     method keep_always_whitespace_mode : unit
  86     method write : output_stream -> encoding -> unit
  87     method write_compact_as_latin1 : output_stream -> unit
  88     method internal_adopt : 'ext node option -> int -> unit
  89     method internal_set_pos : int -> unit
  90     method internal_delete : 'ext node -> unit
  91     method internal_init : (string * int * int) ->
  92                            dtd -> string -> (string * string) list -> unit
  93     method internal_init_other : (string * int * int) ->
  94                                  dtd -> node_type -> unit
  95   end
  96 ;;
  97
  98 type 'ext spec_table =
  99     { mapping : (string, 'ext node) Hashtbl.t;
 100       data_node : 'ext node;
 101       default_element : 'ext node;
 102       super_root_node : 'ext node option;
 103       pinstr_mapping : (string, 'ext node) Hashtbl.t;
 104       default_pinstr_node : 'ext node option;
 105       comment_node : 'ext node option;
 106     }
 107 ;;
 108
 109 type 'ext spec =
 110   Spec_table of 'ext spec_table
 111 ;;
 112
 113
 114 let make_spec_from_mapping
 115       ?super_root_exemplar
 116       ?comment_exemplar
 117       ?default_pinstr_exemplar
 118       ?pinstr_mapping
 119       ~data_exemplar ~default_element_exemplar ~element_mapping () =
 120   Spec_table
 121     { mapping = element_mapping;
 122       data_node = data_exemplar;
 123       default_element = default_element_exemplar;
 124       super_root_node = super_root_exemplar;
 125       comment_node = comment_exemplar;
 126       default_pinstr_node = default_pinstr_exemplar;
 127       pinstr_mapping =
 128         (match pinstr_mapping with
 129              None -> Hashtbl.create 1
 130            | Some m -> m
 131         )
 132     }
 133 ;;
 134
 135
 136 let make_spec_from_alist
 137       ?super_root_exemplar
 138       ?comment_exemplar
 139       ?default_pinstr_exemplar
 140       ?(pinstr_alist = [])
 141       ~data_exemplar ~default_element_exemplar ~element_alist () =
 142   let m = List.length  pinstr_alist in
 143   let pinstr_mapping = Hashtbl.create m in
 144   List.iter
 145     (fun (name,ex) -> Hashtbl.add pinstr_mapping name ex)
 146     pinstr_alist;
 147   let n = List.length  element_alist in
 148   let element_mapping = Hashtbl.create m in
 149   List.iter
 150     (fun (name,ex) -> Hashtbl.add element_mapping name ex)
 151     element_alist;
 152   make_spec_from_mapping
 153     ?super_root_exemplar:      super_root_exemplar
 154     ?comment_exemplar:         comment_exemplar
 155     ?default_pinstr_exemplar:  default_pinstr_exemplar
 156     ~pinstr_mapping:           pinstr_mapping
 157     ~data_exemplar:            data_exemplar
 158     ~default_element_exemplar: default_element_exemplar
 159     ~element_mapping:          element_mapping
 160     ()
 161 ;;
 162
 163 (**********************************************************************)
 164
 165 exception Found;;
 166
 167 let validate_content ?(use_dfa=None) model (el : 'a node) =
 168   (* checks that the nodes of 'el' matches the DTD. Returns 'true'
 169    * on success and 'false' on failure.
 170    *)
 171
 172   let rec is_empty cl =
 173     (* Whether the node list counts as empty or not. *)
 174     match cl with
 175         [] -> true
 176       | n :: cl' ->
 177           ( match n # node_type with
 178               | T_element _     -> false
 179               | _               -> is_empty cl'    (* ignore other nodes *)
 180           )
 181   in
 182
 183   let rec run_regexp cl ml =
 184     (* Validates regexp content models ml against instances cl. This
 185      * function works for deterministic and non-determninistic models.
 186      * The implementation uses backtracking and may sometimes be slow.
 187      *
 188      * cl:   the list of children that will have to be matched
 189      * ml:   the list of regexps that will have to match (to be read as
 190      *       sequence)
 191      * returns () meaning that no match has been found, or raises Found.
 192      *)
 193     match ml with
 194         [] ->
 195           if cl = [] then raise Found;      (* Frequent case *)
 196           if is_empty cl then raise Found;  (* General condition *)
 197       | Seq seq :: ml' ->
 198           assert (seq <> []);     (* necessary to ensure termination *)
 199           run_regexp cl (seq @ ml')
 200       | Alt alts :: ml' ->
 201           let rec find alts =
 202             match alts with
 203                 [] -> ()
 204               | alt :: alts' ->
 205                   run_regexp cl (alt :: ml');
 206                   find alts'
 207           in
 208           assert (alts <> []);      (* Alt [] matches nothing *)
 209           find alts
 210       | Repeated re :: ml' ->
 211           let rec norm re =     (* to avoid infinite loops *)
 212             match re with
 213                 Repeated subre  -> norm subre    (* necessary *)
 214               | Optional subre  -> norm subre    (* necessary *)
 215               | Repeated1 subre -> norm subre    (* an optimization *)
 216               | _               -> re
 217           in
 218           let re' = norm re in
 219           run_regexp cl (re' :: Repeated re' :: ml');
 220           run_regexp cl ml'
 221       | Repeated1 re :: ml' ->
 222           run_regexp cl (re :: Repeated re :: ml')
 223       | Optional re :: ml' ->
 224           run_regexp cl (re :: ml');
 225           run_regexp cl ml';
 226       | Child chld :: ml' ->
 227           match cl with
 228               [] ->
 229                 ()
 230             | sub_el :: cl' ->
 231                 begin match sub_el # node_type with
 232                     T_data ->                       (* Ignore data *)
 233                       run_regexp cl' ml
 234                       (* Note: It can happen that we find a data node here
 235                        * if the 'keep_always_whitespace' mode is turned on.
 236                        *)
 237                   | T_element nt ->
 238                       if nt = chld then run_regexp cl' ml'
 239                   | _ ->                            (* Ignore this element *)
 240                       run_regexp cl' ml
 241                 end
 242   in
 243
 244   let run_dfa cl dfa =
 245     (* Validates regexp content models ml against instances cl. This
 246      * function works ONLY for deterministic models.
 247      * The implementation executes the automaton.
 248      *)
 249     let current_vertex = ref dfa.dfa_start in
 250     let rec next_step cl =
 251       match cl with
 252           el :: cl' ->
 253             begin match el # node_type with
 254                 T_data ->                       (* Ignore data *)
 255                   next_step cl'
 256                     (* Note: It can happen that we find a data node here
 257                      * if the 'keep_always_whitespace' mode is turned on.
 258                      *)
 259               | T_element nt ->
 260                   begin try
 261                     current_vertex := Graph.follow_edge !current_vertex nt;
 262                     next_step cl'
 263                   with
 264                       Not_found -> false
 265                   end
 266               | _ ->                         (* Ignore this node *)
 267                   next_step cl'
 268             end
 269         | [] ->
 270             VertexSet.mem !current_vertex dfa.dfa_stops
 271     in
 272     next_step cl
 273   in
 274
 275   match model with
 276       Unspecified -> true
 277     | Any -> true
 278     | Empty ->
 279         let cl = el # sub_nodes in
 280         is_empty cl
 281     | Mixed (MPCDATA :: mix) ->
 282         let mix' = List.map (function
 283                                  MPCDATA -> assert false
 284                                | MChild x -> x)
 285                             mix in
 286         begin try
 287           el # iter_nodes
 288             (fun sub_el ->
 289                let nt = sub_el # node_type in
 290                match nt with
 291                | T_element name ->
 292                    if not (List.mem name mix') then raise Not_found;
 293                | _ -> ()
 294             );
 295           true
 296         with
 297             Not_found ->
 298               false
 299         end
 300     | Regexp re ->
 301         let cl = el # sub_nodes in
 302         begin match use_dfa with
 303             None ->
 304               (* General backtracking implementation: *)
 305               begin try
 306                 run_regexp cl [re];
 307                 false
 308               with
 309                   Found -> true
 310               end
 311           | Some dfa ->
 312               run_dfa cl dfa
 313         end
 314
 315     | _ -> assert false
 316 ;;
 317
 318 (**********************************************************************)
 319
 320
 321 class virtual ['ext] node_impl an_ext =
 322   object (self)
 323     constraint 'ext = 'ext node #extension
 324
 325     val mutable parent = (None : 'ext node option)
 326     val mutable node_position = -1
 327     val mutable dtd = (None : dtd option)
 328     val mutable extension = an_ext
 329
 330     initializer
 331       extension # set_node (self : 'ext #node  :> 'ext node)
 332
 333
 334     method extension = (extension : 'ext)
 335
 336     method delete =
 337       match parent with
 338           None -> ()
 339         | Some p -> p # internal_delete (self : 'ext #node :> 'ext node)
 340
 341     method parent =
 342       match parent with
 343           None -> raise Not_found
 344         | Some p -> p
 345
 346     method root =
 347       match parent with
 348           None -> (self : 'ext #node :> 'ext node)
 349         | Some p -> p # root
 350
 351     method node_position =
 352       if node_position >= 0 then node_position else
 353         raise Not_found
 354
 355     method node_path =
 356       let rec collect n path =
 357         try
 358           let p = n # node_position in
 359           collect (n # parent) (p :: path)
 360         with
 361             Not_found ->
 362               (* n is the root *)
 363               path
 364       in
 365       collect (self : 'ext #node :> 'ext node) []
 366
 367     method previous_node =
 368       self # parent # nth_node (self # node_position - 1)
 369
 370     method next_node =
 371       self # parent # nth_node (self # node_position + 1)
 372
 373     method orphaned_clone =
 374       let x = extension # clone in
 375       let n =
 376         {< parent = None;
 377            node_position = -1;
 378            extension = x;
 379         >} in
 380       x # set_node (n : 'ext #node  :> 'ext node);
 381       n
 382
 383     method orphaned_flat_clone =
 384       let x = extension # clone in
 385       let n =
 386         {< parent = None;
 387            node_position = -1;
 388            extension = x;
 389         >} in
 390       x # set_node (n : 'ext #node  :> 'ext node);
 391       n
 392
 393     method dtd =
 394       match dtd with
 395           None -> failwith "Pxp_document.node_impl#dtd: No DTD available"
 396         | Some d -> d
 397
 398     method encoding =
 399       match dtd with
 400           None -> failwith "Pxp_document.node_impl#encoding: No DTD available"
 401         | Some d -> d # encoding
 402
 403     method internal_adopt (new_parent : 'ext node option) pos =
 404       begin match parent with
 405           None -> ()
 406         | Some p ->
 407             if new_parent <> None then
 408               failwith "Pxp_document.node_impl#internal_adopt: Tried to add a bound element"
 409       end;
 410       parent <- new_parent;
 411       node_position <- pos
 412
 413     method internal_set_pos pos =
 414       node_position <- pos
 415
 416     method virtual add_node : ?force:bool -> 'ext node -> unit
 417     method virtual add_pinstr : proc_instruction -> unit
 418     method virtual sub_nodes : 'ext node list
 419     method virtual pinstr : string -> proc_instruction list
 420     method virtual pinstr_names : string list
 421     method virtual iter_nodes : ('ext node -> unit) -> unit
 422     method virtual iter_nodes_sibl : ('ext node option -> 'ext node -> 'ext node option -> unit) -> unit
 423     method virtual nth_node : int -> 'ext node
 424     method virtual set_nodes : 'ext node list -> unit
 425     method virtual data : string
 426     method virtual node_type : node_type
 427     method virtual position : (string * int * int)
 428     method virtual attribute : string -> att_value
 429     method virtual attribute_names : string list
 430     method virtual attribute_type : string -> att_type
 431     method virtual attributes : (string * Pxp_types.att_value) list
 432     method virtual required_string_attribute : string -> string
 433     method virtual required_list_attribute : string -> string list
 434     method virtual optional_string_attribute : string -> string option
 435     method virtual optional_list_attribute : string -> string list
 436     method virtual quick_set_attributes : (string * Pxp_types.att_value) list -> unit
 437     method virtual attributes_as_nodes : 'ext node list
 438     method virtual set_comment : string option -> unit
 439     method virtual comment : string option
 440     method virtual create_element :
 441                    ?position:(string * int * int) ->
 442                    dtd -> node_type -> (string * string) list -> 'ext node
 443     method virtual create_data : dtd -> string -> 'ext node
 444     method virtual keep_always_whitespace_mode : unit
 445     method virtual write : output_stream -> encoding -> unit
 446     method virtual write_compact_as_latin1 : output_stream -> unit
 447     method virtual local_validate : ?use_dfa:bool -> unit -> unit
 448     method virtual internal_delete : 'ext node -> unit
 449     method virtual internal_init : (string * int * int) ->
 450                                 dtd -> string -> (string * string) list -> unit
 451     method virtual internal_init_other : (string * int * int) ->
 452                                          dtd -> node_type -> unit
 453   end
 454 ;;
 455
 456
 457 (**********************************************************************)
 458
 459 let no_position = ("?", 0, 0) ;;
 460
 461
 462 class ['ext] data_impl an_ext : ['ext] node =
 463   object (self)
 464     inherit ['ext] node_impl an_ext
 465     val mutable content = ("" : string)
 466
 467     method position = no_position
 468
 469     method add_node ?(force=false) _ =
 470       failwith "method 'add_node' not applicable to data node"
 471     method add_pinstr _ =
 472       failwith "method 'add_pinstr' not applicable to data node"
 473     method pinstr _ = []
 474     method pinstr_names = []
 475     method sub_nodes = []
 476     method iter_nodes _ = ()
 477     method iter_nodes_sibl _ = ()
 478     method nth_node _ = raise Not_found
 479     method set_nodes _ =
 480       failwith "method 'set_nodes' not applicable to data node"
 481     method data = content
 482     method node_type = T_data
 483     method attribute _ = raise Not_found
 484     method attribute_names = []
 485     method attribute_type _ = raise Not_found
 486     method attributes = []
 487     method required_string_attribute _ =
 488       failwith "Markup.document, method required_string_attribute: not found"
 489     method required_list_attribute _ =
 490       failwith "Markup.document, method required_list_attribute: not found"
 491     method optional_string_attribute _ = None
 492     method optional_list_attribute _ = []
 493     method id_attribute_name = raise Not_found
 494     method id_attribute_value = raise Not_found
 495     method idref_attribute_names = []
 496     method quick_set_attributes _ =
 497       failwith "method 'quick_set_attributes' not applicable to data node"
 498     method attributes_as_nodes = []
 499     method comment = None
 500     method set_comment c =
 501       match c with
 502           None -> ()
 503         | Some _ -> failwith "method 'set_comment' not applicable to data node"
 504     method create_element ?position _ _ _ =
 505       failwith "method 'create_element' not applicable to data node"
 506     method create_data new_dtd new_str =
 507       let x = extension # clone in
 508       let n =
 509       ( {< parent = None;
 510            extension = x;
 511            dtd = Some new_dtd;
 512            content = new_str;
 513         >}
 514         : 'ext #node :> 'ext node) in
 515       x # set_node n;
 516       n
 517     method local_validate ?use_dfa () = ()
 518     method keep_always_whitespace_mode = ()
 519
 520
 521     method write os enc =
 522       let encoding = self # encoding in
 523       write_data_string ~from_enc:encoding ~to_enc:enc os content
 524
 525
 526     method write_compact_as_latin1 os =
 527       self # write os `Enc_iso88591
 528
 529     method internal_delete _ =
 530       assert false
 531     method internal_init _ _ _ _ =
 532       assert false
 533     method internal_init_other _ _ _ =
 534       assert false
 535   end
 536 ;;
 537
 538
 539 (**********************************************************************)
 540
 541 class ['ext] attribute_impl ~element ~name value dtd =
 542   (object (self)
 543      val mutable parent = (None : 'ext node option)
 544      val mutable dtd = dtd
 545      val mutable element_name = element
 546      val mutable att_name = name
 547      val mutable att_value = value
 548
 549      method parent =
 550        match parent with
 551            None -> raise Not_found
 552          | Some p -> p
 553
 554      method root =
 555        match parent with
 556            None -> (self : 'ext #node :> 'ext node)
 557          | Some p -> p # root
 558
 559      method internal_adopt new_parent _ =
 560        parent <- new_parent
 561
 562      method orphaned_clone =
 563        {< parent = None >}
 564
 565      method orphaned_flat_clone =
 566        {< parent = None >}
 567
 568      method dtd = dtd
 569
 570      method encoding = dtd # encoding
 571
 572      method node_type = T_attribute att_name
 573
 574      method attribute n =
 575        if n = att_name then att_value else raise Not_found
 576
 577      method attribute_names = [ att_name ]
 578
 579      method attribute_type n =
 580        let eltype = dtd # element element_name in
 581        ( try
 582            let atype, adefault = eltype # attribute n in
 583            atype
 584          with
 585              Undeclared ->
 586                A_cdata
 587        )
 588
 589      method attributes = [ att_name, att_value ]
 590
 591      method required_string_attribute n =
 592        if n = att_name then
 593          match att_value with
 594              Value s -> s
 595            | Valuelist l -> String.concat " " l
 596            | Implied_value -> raise Not_found
 597        else
 598          failwith "Pxp_document.attribute_impl#required_string_attribute: not found"
 599
 600
 601      method required_list_attribute n =
 602        if n = att_name then
 603          match att_value with
 604              Value s -> [ s ]
 605            | Valuelist l -> l
 606            | Implied_value -> raise Not_found
 607        else
 608          failwith "Pxp_document.attribute_impl#required_list_attribute: not found"
 609
 610      method optional_string_attribute n =
 611        if n = att_name then
 612          match att_value with
 613              Value s -> Some s
 614            | Valuelist l -> Some(String.concat " " l)
 615            | Implied_value -> None
 616        else
 617          None
 618
 619      method optional_list_attribute n =
 620        if n = att_name then
 621          match att_value with
 622              Value s -> [ s ]
 623            | Valuelist l -> l
 624            | Implied_value -> []
 625        else
 626          []
 627
 628     (* Senseless methods: *)
 629
 630      method sub_nodes = []
 631      method pinstr _ = []
 632      method pinstr_names = []
 633      method iter_nodes _ = ()
 634      method iter_nodes_sibl _ = ()
 635      method nth_node _ = raise Not_found
 636      method data = ""
 637      method position = ("?",0,0)
 638      method comment = None
 639      method local_validate ?use_dfa () = ()
 640
 641     (* Non-applicable methods: *)
 642
 643      method extension =
 644        failwith "Pxp_document.attribute_impl#extension: not applicable"
 645      method delete =
 646        failwith "Pxp_document.attribute_impl#delete: not applicable"
 647      method node_position =
 648        failwith "Pxp_document.attribute_impl#node_position: not applicable"
 649      method node_path =
 650        failwith "Pxp_document.attribute_impl#node_path: not applicable"
 651      method previous_node =
 652        failwith "Pxp_document.attribute_impl#previous_node: not applicable"
 653      method next_node =
 654        failwith "Pxp_document.attribute_impl#next_node: not applicable"
 655      method internal_set_pos _ =
 656        failwith "Pxp_document.attribute_impl#internal_set_pos: not applicable"
 657      method internal_delete _ =
 658        failwith "Pxp_document.attribute_impl#internal_delete: not applicable"
 659      method internal_init _ _ _ _ =
 660        failwith "Pxp_document.attribute_impl#internal_init: not applicable"
 661      method internal_init_other _ _ _ =
 662        failwith "Pxp_document.attribute_impl#internal_init_other: not applicable"
 663      method add_node ?force _ =
 664        failwith "Pxp_document.attribute_impl#add_node: not applicable"
 665      method add_pinstr _ =
 666        failwith "Pxp_document.attribute_impl#add_pinstr: not applicable"
 667      method set_nodes _ =
 668        failwith "Pxp_document.attribute_impl#set_nodes: not applicable"
 669      method quick_set_attributes _ =
 670        failwith "Pxp_document.attribute_impl#quick_set_attributes: not applicable"
 671      method attributes_as_nodes =
 672        failwith "Pxp_document.attribute_impl#dattributes_as_nodes: not applicable"
 673      method set_comment c =
 674        if c <> None then
 675          failwith "Pxp_document.attribute_impl#set_comment: not applicable"
 676      method create_element ?position _ _ _ =
 677        failwith "Pxp_document.attribute_impl#create_element: not applicable"
 678      method create_data _ _ =
 679        failwith "Pxp_document.attribute_impl#create_data: not applicable"
 680      method keep_always_whitespace_mode =
 681        failwith "Pxp_document.attribute_impl#keep_always_whitespace_mode: not applicable"
 682      method write _ _ =
 683        failwith "Pxp_document.attribute_impl#write: not applicable"
 684      method write_compact_as_latin1 _ =
 685        failwith "Pxp_document.attribute_impl#write_compact_as_latin1: not applicable"
 686      method id_attribute_name =
 687        failwith "Pxp_document.attribute_impl#id_attribute_name: not applicable"
 688      method id_attribute_value =
 689        failwith "Pxp_document.attribute_impl#id_attribute_value: not applicable"
 690      method idref_attribute_names =
 691        failwith "Pxp_document.attribute_impl#idref_attribute_names: not applicable"
 692    end
 693      : ['ext] node)
 694 ;;
 695
 696 (**********************************************************************)
 697
 698 class ['ext] element_impl an_ext : ['ext] node =
 699     object (self:'self)
 700       inherit ['ext] node_impl an_ext as super
 701
 702       val mutable content_model = Any
 703       val mutable content_dfa = lazy None
 704       val mutable ext_decl = false
 705       val mutable ntype = T_none
 706       val mutable id_att_name = None
 707       val mutable idref_att_names = []
 708       val mutable rev_nodes = ([] : 'c list)
 709       val mutable nodes = (None : 'c list option)
 710       val mutable array = (None : 'c array option)
 711       val mutable size = 0
 712       val mutable attributes = []
 713       val mutable att_nodes = []
 714       val mutable comment = None
 715       val pinstr = lazy (Hashtbl.create 10 : (string,proc_instruction) Hashtbl.t)
 716       val mutable keep_always_whitespace = false
 717
 718       val mutable position = no_position
 719
 720       method comment = comment
 721
 722       method set_comment c =
 723         if ntype = T_comment then
 724           comment <- c
 725         else
 726           failwith "set_comment: not applicable to node types other than T_comment"
 727
 728       method attributes = attributes
 729
 730       method position = position
 731
 732       method private error_name =
 733         match ntype with
 734             T_element n -> "Element `" ^ n ^ "'"
 735           | T_super_root -> "Super root"
 736           | T_pinstr n -> "Wrapper element for processing instruction `" ^ n ^
 737               "'"
 738           | T_comment -> "Wrapper element for comment"
 739           | T_none -> "NO element"
 740           | T_attribute _ -> assert false
 741           | T_namespace _ -> assert false
 742           | T_data -> assert false
 743
 744       method add_node ?(force = false) n =
 745         let only_whitespace s =
 746           (* Checks that the string "s" contains only whitespace. On failure,
 747            * Validation_error is raised.
 748            *)
 749           let l = String.length s in
 750           if l < 100 then begin
 751             for i=0 to l - 1 do  (* for loop is faster for small 'l' *)
 752               match s.[i] with
 753                   ('\009'|'\010'|'\013'|'\032') -> ()
 754                 | _ ->
 755                     raise(Validation_error(self # error_name ^
 756                                            " must not have character contents"));
 757             done
 758           end
 759           else begin
 760             let lexbuf = Lexing.from_string s in
 761             let lexerset = Pxp_lexers.get_lexer_set (self # dtd # encoding) in
 762             let t = lexerset.scan_name_string lexbuf in
 763             if t <> Ignore or
 764               (lexerset.scan_name_string lexbuf <> Eof)
 765             then
 766               raise(Validation_error(self # error_name ^
 767                                      " must not have character contents"));
 768             ()
 769           end
 770         in
 771         (* general DTD check: *)
 772         begin match dtd with
 773             None -> ()
 774           | Some d -> if n # dtd != d then
 775               failwith "Pxp_document.element_impl # add_node: the sub node has a different DTD";
 776         end;
 777         (* specific checks: *)
 778         try
 779           begin match n # node_type with
 780               T_data ->
 781                 begin match content_model with
 782                     Any         -> ()
 783                   | Unspecified -> ()
 784                   | Empty       ->
 785                       if not force then begin
 786                         if n # data <> "" then
 787                           raise(Validation_error(self # error_name ^
 788                                                  " must be empty"));
 789                         raise Skip
 790                       end
 791                   | Mixed _     -> ()
 792                   | Regexp _    ->
 793                       if not force then begin
 794                         only_whitespace (n # data);
 795                         (* TODO: following check faster *)
 796                         if n # dtd # standalone_declaration &&
 797                           n # data <> ""
 798                         then begin
 799                           (* The standalone declaration is violated if the
 800                            * element declaration is contained in an external
 801                            * entity.
 802                            *)
 803                           if ext_decl then
 804                             raise
 805                               (Validation_error
 806                                  (self # error_name ^
 807                                   " violates standalone declaration"  ^
 808                                   " because extra white space separates" ^
 809                                   " the sub elements"));
 810                         end;
 811                         if not keep_always_whitespace then raise Skip
 812                       end
 813                 end
 814             | _ ->
 815                 ()
 816           end;
 817           (* all OK, so add this node: *)
 818           n # internal_adopt (Some (self : 'ext #node :> 'ext node)) size;
 819           rev_nodes <- n :: rev_nodes;
 820           nodes <- None;
 821           array <- None;
 822           size <- size + 1
 823         with Skip ->
 824           ()
 825
 826       method add_pinstr pi =
 827         begin match dtd with
 828             None -> ()
 829           | Some d ->
 830               if pi # encoding <> d # encoding then
 831                 failwith "Pxp_document.element_impl # add_pinstr: Inconsistent encodings";
 832         end;
 833         let name = pi # target in
 834         Hashtbl.add (Lazy.force pinstr) name pi
 835
 836       method pinstr name =
 837         Hashtbl.find_all (Lazy.force pinstr) name
 838
 839       method pinstr_names =
 840         let l = ref [] in
 841         Hashtbl.iter
 842           (fun n _ -> l := n :: !l)
 843           (Lazy.force pinstr);
 844         !l
 845
 846       method sub_nodes =
 847         match nodes with
 848             None ->
 849               let cl = List.rev rev_nodes in
 850               nodes <- Some cl;
 851               cl
 852           | Some cl ->
 853               cl
 854
 855       method iter_nodes f =
 856         let cl = self # sub_nodes in
 857         List.iter f cl
 858
 859       method iter_nodes_sibl f =
 860         let cl = self # sub_nodes in
 861         let rec next last_node l =
 862           match l with
 863               [] -> ()
 864             | [x] ->
 865                 f last_node x None
 866             | x :: y :: l' ->
 867                 f last_node x (Some y);
 868                 next (Some x) l'
 869         in
 870         next None cl
 871
 872       method nth_node p =
 873         if p < 0 or p >= size then raise Not_found;
 874         if array = None then
 875           array <- Some (Array.of_list (self # sub_nodes));
 876         match array with
 877             None -> assert false
 878           | Some a ->
 879               a.(p)
 880
 881       method set_nodes nl =
 882         let old_size = size in
 883         List.iter
 884           (fun n -> n # internal_adopt None (-1))
 885           rev_nodes;
 886         begin try
 887           size <- 0;
 888           List.iter
 889             (fun n -> n # internal_adopt
 890                             (Some (self : 'ext #node :> 'ext node))
 891                             size;
 892                       size <- size + 1)
 893             nl
 894         with
 895             e ->
 896               (* revert action as much as possible *)
 897               List.iter
 898                 (fun n -> n # internal_adopt None (-1))
 899                 rev_nodes;
 900               size <- old_size;
 901               let pos = ref (size-1) in
 902               List.iter
 903                 (fun n -> n # internal_adopt
 904                                 (Some (self : 'ext #node :> 'ext node))
 905                                 !pos;
 906                           decr pos
 907                 )
 908                 rev_nodes;
 909               (* [TODO] Note: there may be bad members in nl *)
 910               raise e
 911         end;
 912         rev_nodes <- List.rev nl;
 913         array <- None;
 914         nodes <- None
 915
 916
 917       method orphaned_clone : 'self =
 918         let sub_clones =
 919           List.map
 920             (fun m ->
 921                m # orphaned_clone)
 922             rev_nodes
 923         in
 924
 925         let x = extension # clone in
 926         let n =
 927           {< parent = None;
 928              node_position = -1;
 929              extension = x;
 930              rev_nodes = sub_clones;
 931              nodes = None;
 932              array = None;
 933           >} in
 934
 935         let pos = ref (size - 1) in
 936         List.iter
 937           (fun m -> m # internal_adopt
 938                       (Some (n : 'ext #node :> 'ext node))
 939                       !pos;
 940                     decr pos
 941           )
 942           sub_clones;
 943
 944         x # set_node (n : 'ext #node  :> 'ext node);
 945         n
 946
 947       method orphaned_flat_clone : 'self =
 948         let x = extension # clone in
 949         let n =
 950           {< parent = None;
 951              node_position = -1;
 952              extension = x;
 953              rev_nodes = [];
 954              nodes = None;
 955              size = 0;
 956              array = None;
 957           >} in
 958
 959         x # set_node (n : 'ext #node  :> 'ext node);
 960         n
 961
 962
 963       method internal_delete n =
 964         rev_nodes <- List.filter (fun n' -> n' != n) rev_nodes;
 965         size <- size - 1;
 966         let p = ref (size-1) in
 967         List.iter
 968           (fun n' -> n' # internal_set_pos !p; decr p)
 969           rev_nodes;
 970         nodes <- None;
 971         n # internal_adopt None (-1);
 972
 973
 974       method data =
 975         let cl = self # sub_nodes in
 976         String.concat "" (List.map (fun n -> n # data) cl)
 977
 978       method node_type = ntype
 979
 980
 981       method attribute n =
 982         List.assoc n attributes
 983
 984       method attribute_names =
 985         List.map fst attributes
 986
 987       method attribute_type n =
 988         match ntype with
 989             T_element name ->
 990               let d =
 991                 match dtd with
 992                     None -> assert false
 993                   | Some d -> d in
 994               let eltype = d # element name in
 995               ( try
 996                   let atype, adefault = eltype # attribute n in
 997                   atype
 998                 with
 999                     Undeclared ->
1000                       A_cdata
1001               )
1002           | _ ->
1003               failwith "attribute_type: not available for non-element nodes"
1004
1005
1006       method required_string_attribute n =
1007         try
1008           match List.assoc n attributes with
1009               Value s -> s
1010             | Valuelist l -> String.concat " " l
1011             | Implied_value -> raise Not_found
1012         with
1013             Not_found ->
1014               failwith "Pxp_document, method required_string_attribute: not found"
1015
1016       method optional_string_attribute n =
1017         try
1018           match List.assoc n attributes with
1019               Value s -> Some s
1020             | Valuelist l -> Some (String.concat " " l)
1021             | Implied_value -> None
1022         with
1023             Not_found ->
1024               None
1025
1026       method required_list_attribute n =
1027         try
1028           match List.assoc n attributes with
1029               Value s -> [ s ]
1030             | Valuelist l -> l
1031             | Implied_value -> raise Not_found
1032         with
1033             Not_found ->
1034               failwith "Markup.document, method required_list_attribute: not found"
1035
1036       method optional_list_attribute n =
1037         try
1038           match List.assoc n attributes with
1039               Value s -> [ s ]
1040             | Valuelist l -> l
1041             | Implied_value -> []
1042         with
1043             Not_found ->
1044               []
1045
1046       method id_attribute_name =
1047         match id_att_name with
1048             None -> raise Not_found
1049           | Some name -> name
1050
1051       method id_attribute_value =
1052         match id_att_name with
1053             None -> raise Not_found
1054           | Some name ->
1055               begin match List.assoc name attributes (* may raise Not_found *)
1056               with
1057                   Value s -> s
1058                 | _ -> raise Not_found
1059               end
1060
1061
1062       method idref_attribute_names = idref_att_names
1063
1064
1065       method quick_set_attributes atts =
1066         match ntype with
1067             T_element _ ->
1068               attributes <- atts;
1069               att_nodes <- []
1070           | _ ->
1071               failwith "quick_set_attributes: not applicable for non-element node"
1072
1073
1074       method attributes_as_nodes =
1075         match att_nodes with
1076             [] when attributes = [] ->
1077               []
1078           | [] ->
1079               let dtd = self # dtd in
1080               let element_name =
1081                 match ntype with
1082                     T_element n -> n
1083                   | _ ->
1084                       assert false in
1085               let l =
1086                 List.map
1087                   (fun (n,v) ->
1088                      new attribute_impl
1089                        ~element:element_name
1090                        ~name:n
1091                        v
1092                        dtd)
1093                   attributes in
1094               att_nodes <- l;
1095               l
1096           | _ ->
1097               att_nodes
1098
1099
1100       method create_element
1101                        ?(position = no_position) new_dtd new_type new_attlist =
1102         let x = extension # clone in
1103         let obj = ( {< parent = None;
1104                        extension = x;
1105                        pinstr = lazy (Hashtbl.create 10)
1106                     >}
1107                     : 'ext #node :> 'ext node
1108                   ) in
1109         x # set_node obj;
1110         match new_type with
1111             T_data ->
1112               failwith "create_element: Cannot create T_data node"
1113           | T_element name ->
1114               obj # internal_init position new_dtd name new_attlist;
1115               obj
1116           | (T_comment | T_pinstr _ | T_super_root | T_none) ->
1117               obj # internal_init_other position new_dtd new_type;
1118               obj
1119           | _ ->
1120               failwith "create_element: Cannot create such node"
1121
1122
1123       method internal_init_other new_pos new_dtd new_ntype =
1124         (* resets the contents of the object *)
1125         parent <- None;
1126         rev_nodes <- [];
1127         nodes <- None;
1128         ntype <- new_ntype;
1129         position <- new_pos;
1130         content_model <- Any;
1131         content_dfa <- lazy None;
1132         attributes <- [];
1133         att_nodes <- [];
1134         dtd <- Some new_dtd;
1135         ext_decl <- false;
1136         id_att_name <- None;
1137         idref_att_names <- [];
1138         comment <- None;
1139
1140
1141       method internal_init new_pos new_dtd new_name new_attlist =
1142         (* ONLY FOR T_Element NODES!!! *)
1143         (* resets the contents of the object *)
1144         parent <- None;
1145         rev_nodes <- [];
1146         nodes <- None;
1147         ntype <- T_element new_name;
1148         position <- new_pos;
1149         comment <- None;
1150         att_nodes <- [];
1151
1152         let lexerset = Pxp_lexers.get_lexer_set (new_dtd # encoding) in
1153         let sadecl = new_dtd # standalone_declaration in
1154
1155         (* First validate the element name and the attributes: *)
1156         (* Well-Formedness Constraint: Unique Att Spec *)
1157         let rec check_uniqueness al =
1158           match al with
1159               [] -> ()
1160             | (n, av) :: al' ->
1161                 if List.mem_assoc n al' then
1162                   raise (WF_error("Attribute `" ^ n ^ "' occurs twice in element `" ^ new_name ^ "'"));
1163                 check_uniqueness al'
1164         in
1165         check_uniqueness new_attlist;
1166         (* Validity Constraint: Element Valid [element has been declared] *)
1167         try
1168           let eltype = new_dtd # element new_name in
1169           content_model <- eltype # content_model;
1170           content_dfa   <- lazy(eltype # content_dfa);
1171           ext_decl <- eltype # externally_declared;
1172           id_att_name <- eltype # id_attribute_name;
1173           idref_att_names <- eltype # idref_attribute_names;
1174           (* Validity Constraint: Attribute Value Type *)
1175           (* Validity Constraint: Fixed Attribute Default *)
1176           (* Validity Constraint: Standalone Document Declaration (partly) *)
1177           let undeclared_attlist = ref [] in
1178           let new_attlist' =
1179             List.map
1180               (fun (n,v) ->
1181                  try
1182                    (* Get type, default, and the normalized attribute
1183                     * value 'av':
1184                     *)
1185                    let atype, adefault = eltype # attribute n in
1186                    let av = value_of_attribute lexerset new_dtd n atype v in
1187                    (* If necessary, check whether normalization violates
1188                     * the standalone declaration.
1189                     *)
1190                    if sadecl &&
1191                       eltype #
1192                         attribute_violates_standalone_declaration n (Some v)
1193                    then
1194                      raise
1195                        (Validation_error
1196                           ("Attribute `" ^ n ^ "' of element type `" ^
1197                            new_name ^ "' violates standalone declaration"));
1198                    (* If the default is "fixed", check that. *)
1199                    begin match adefault with
1200                        (D_required | D_implied) -> ()
1201                      | D_default _ -> ()
1202                      | D_fixed u ->
1203                          let uv = value_of_attribute
1204                                          lexerset new_dtd "[default]" atype u in
1205                          if av <> uv then
1206                            raise
1207                              (Validation_error
1208                                 ("Attribute `" ^ n ^
1209                                  "' is fixed, but has here a different value"));
1210                    end;
1211                    n,av
1212                  with
1213                      Undeclared ->
1214                        (* raised by method "# attribute" *)
1215                        undeclared_attlist :=
1216                          (n, value_of_attribute lexerset new_dtd n A_cdata v) ::
1217                          !undeclared_attlist;
1218                        n, Implied_value        (* does not matter *)
1219               )
1220               new_attlist in
1221           (* Validity Constraint: Required Attribute *)
1222           (* Validity Constraint: Standalone Document Declaration (partly) *)
1223           (* Add attributes with default values *)
1224           let new_attlist'' =
1225             List.map
1226               (fun n ->
1227                  try
1228                    n, List.assoc n new_attlist'
1229                  with
1230                      Not_found ->
1231                        (* Check standalone declaration: *)
1232                        if sadecl &&
1233                             eltype #
1234                             attribute_violates_standalone_declaration
1235                             n None then
1236                          raise
1237                            (Validation_error
1238                               ("Attribute `" ^ n ^ "' of element type `" ^
1239                                new_name ^ "' violates standalone declaration"));
1240                        (* add default value or Implied *)
1241                        let atype, adefault = eltype # attribute n in
1242                        match adefault with
1243                            D_required ->
1244                              raise(Validation_error("Required attribute `" ^ n ^ "' is missing"))
1245                          | D_implied ->
1246                              n, Implied_value
1247                          | D_default v ->
1248                              n, value_of_attribute lexerset new_dtd n atype v
1249                          | D_fixed v ->
1250                              n, value_of_attribute lexerset new_dtd n atype v
1251               )
1252               (eltype # attribute_names)
1253           in
1254           dtd <- Some new_dtd;
1255           attributes <- new_attlist'' @ !undeclared_attlist;
1256         with
1257             Undeclared ->
1258               (* The DTD allows arbitrary attributes/contents for this
1259                * element
1260                *)
1261               dtd <- Some new_dtd;
1262               attributes <- List.map (fun (n,v) -> n, Value v) new_attlist;
1263               content_model <- Any;
1264               content_dfa <- lazy None;
1265
1266       method local_validate ?(use_dfa=false) () =
1267         (* validates that the content of this element matches the model *)
1268         let dfa = if use_dfa then Lazy.force content_dfa else None in
1269         if not (validate_content
1270                   ~use_dfa:dfa
1271                   content_model
1272                   (self : 'ext #node :> 'ext node)) then
1273           raise(Validation_error(self # error_name ^
1274                                  " does not match its content model"))
1275
1276
1277       method create_data _ _ =
1278         failwith "method 'create_data' not applicable to element node"
1279
1280       method keep_always_whitespace_mode =
1281         keep_always_whitespace <- true
1282
1283       method write os enc =
1284         let encoding = self # encoding in
1285         let wms =
1286           write_markup_string ~from_enc:encoding ~to_enc:enc os in
1287
1288         begin match ntype with
1289             T_element name ->
1290               wms ("<" ^ name);
1291               List.iter
1292                 (fun (aname, avalue) ->
1293                    match avalue with
1294                        Implied_value -> ()
1295                      | Value v ->
1296                          wms ("\n" ^ aname ^ "=\"");
1297                          write_data_string ~from_enc:encoding ~to_enc:enc os v;
1298                          wms "\"";
1299                      | Valuelist l ->
1300                          let v = String.concat " " l in
1301                          wms ("\n" ^ aname ^ "=\"");
1302                          write_data_string ~from_enc:encoding ~to_enc:enc os v;
1303                          wms "\"";
1304                 )
1305                 attributes;
1306               wms "\n>";
1307           | _ ->
1308               ()
1309         end;
1310
1311         Hashtbl.iter
1312           (fun n pi ->
1313              pi # write os enc
1314           )
1315           (Lazy.force pinstr);
1316         List.iter
1317           (fun n -> n # write os enc)
1318           (self # sub_nodes);
1319
1320         begin match ntype with
1321             T_element name ->
1322               wms ("</" ^ name ^ "\n>");
1323           | _ ->
1324               ()
1325         end
1326
1327         (* TODO: How to write comments? The comment string may contain
1328          * illegal characters or "--".
1329          *)
1330
1331
1332       method write_compact_as_latin1 os =
1333         self # write os `Enc_iso88591
1334
1335     end
1336 ;;
1337
1338
1339 let spec_table_find_exemplar tab eltype =
1340   try
1341     Hashtbl.find tab.mapping eltype
1342   with
1343       Not_found -> tab.default_element
1344 ;;
1345
1346
1347 let create_data_node spec dtd str =
1348   match spec with
1349       Spec_table tab ->
1350         let exemplar = tab.data_node in
1351         exemplar # create_data dtd str
1352 ;;
1353
1354
1355 let create_element_node ?position spec dtd eltype atts =
1356    match spec with
1357       Spec_table tab ->
1358         let exemplar = spec_table_find_exemplar tab eltype in
1359         exemplar # create_element ?position:position dtd (T_element eltype) atts
1360 ;;
1361
1362
1363 let create_super_root_node ?position spec dtd =
1364     match spec with
1365       Spec_table tab ->
1366         ( match tab.super_root_node with
1367               None ->
1368                 failwith "Pxp_document.create_super_root_node: No exemplar"
1369             | Some x ->
1370                 x # create_element ?position:position dtd T_super_root []
1371         )
1372 ;;
1373
1374 let create_no_node ?position spec dtd =
1375     match spec with
1376       Spec_table tab ->
1377         let x = tab.default_element in
1378         x # create_element ?position:position dtd T_none []
1379 ;;
1380
1381
1382 let create_comment_node ?position spec dtd text =
1383   match spec with
1384       Spec_table tab ->
1385         ( match tab.comment_node with
1386               None ->
1387                 failwith "Pxp_document.create_comment_node: No exemplar"
1388             | Some x ->
1389                 let e = x # create_element ?position:position dtd T_comment []
1390                 in
1391                 e # set_comment (Some text);
1392                 e
1393         )
1394 ;;
1395
1396
1397 let create_pinstr_node ?position spec dtd pi =
1398   let target = pi # target in
1399   let exemplar =
1400     match spec with
1401         Spec_table tab ->
1402           ( try
1403               Hashtbl.find tab.pinstr_mapping target
1404             with
1405                 Not_found ->
1406                   ( match tab.default_pinstr_node with
1407                         None ->
1408                           failwith
1409                             "Pxp_document.create_pinstr_node: No exemplar"
1410                       | Some x -> x
1411                   )
1412           )
1413   in
1414   let el =
1415     exemplar # create_element ?position:position dtd (T_pinstr target) [] in
1416   el # add_pinstr pi;
1417   el
1418 ;;
1419
1420
1421 let find ?(deeply=false) f base =
1422   let rec search_flat children =
1423     match children with
1424         [] -> raise Not_found
1425       | n :: children' ->
1426           if f n then n else search_flat children'
1427   in
1428   let rec search_deep children =
1429     match children with
1430         [] -> raise Not_found
1431       | n :: children' ->
1432           if f n then
1433             n
1434           else
1435             try search_deep (n # sub_nodes)
1436             with Not_found -> search_deep children'
1437   in
1438   (if deeply then search_deep else search_flat)
1439   (base # sub_nodes)
1440 ;;
1441
1442
1443 let find_all ?(deeply=false) f base =
1444   let rec search_flat children =
1445     match children with
1446         [] -> []
1447       | n :: children' ->
1448           if f n then n :: search_flat children' else search_flat children'
1449   in
1450   let rec search_deep children =
1451     match children with
1452         [] -> []
1453       | n :: children' ->
1454           let rest =
1455             search_deep (n # sub_nodes) @ search_deep children' in
1456           if f n then
1457             n :: rest
1458           else
1459             rest
1460   in
1461   (if deeply then search_deep else search_flat)
1462   (base # sub_nodes)
1463 ;;
1464
1465
1466 let find_element ?deeply eltype base =
1467   find
1468     ?deeply:deeply
1469     (fun n ->
1470        match n # node_type with
1471            T_element name -> name = eltype
1472          | _              -> false)
1473     base
1474 ;;
1475
1476
1477 let find_all_elements ?deeply eltype base =
1478   find_all
1479     ?deeply:deeply
1480     (fun n ->
1481        match n # node_type with
1482            T_element name -> name = eltype
1483          | _              -> false)
1484     base
1485 ;;
1486
1487
1488 exception Skip;;
1489
1490 let map_tree ~pre ?(post=(fun x -> x)) base =
1491   let rec map_rec n =
1492     (try
1493       let n' = pre n in
1494       if n' # node_type <> T_data then begin
1495         let children = n # sub_nodes in
1496         let children' = map_children children in
1497         n' # set_nodes children';
1498       end;
1499       post n'
1500     with
1501         Skip -> raise Not_found
1502     )
1503   and map_children l =
1504     match l with
1505         [] -> []
1506       | child :: l' ->
1507           (try
1508              let child' = map_rec child in
1509              child' :: map_children l'
1510            with
1511                Not_found ->
1512                  map_children l'
1513           )
1514   in
1515   map_rec base
1516 ;;
1517
1518
1519 let map_tree_sibl ~pre ?(post=(fun _ x _ -> x)) base =
1520   let rec map_rec l n r =
1521     (try
1522       let n' = pre l n r in
1523       if n' # node_type <> T_data then begin
1524         let children = n # sub_nodes in
1525         let children' = map_children None children in
1526         let children'' = postprocess_children None children' in
1527         n' # set_nodes children'';
1528       end;
1529       n'
1530     with
1531         Skip -> raise Not_found
1532     )
1533   and map_children predecessor l =
1534     (match l with
1535          [] -> []
1536        | child :: l' ->
1537            let successor =
1538              match l' with
1539                  []    -> None
1540               | x :: _ -> Some x in
1541            (try
1542               let child' = map_rec predecessor child successor in
1543               child' :: map_children (Some child) l'
1544             with
1545                 Not_found ->
1546                   map_children (Some child) l'
1547            )
1548     )
1549   and postprocess_children predecessor l =
1550     (match l with
1551          [] -> []
1552        | child :: l' ->
1553            let successor =
1554              match l' with
1555                  []     -> None
1556                | x :: _ -> Some x in
1557            (try
1558               let child' = post predecessor child successor in
1559               child' :: postprocess_children (Some child) l'
1560             with
1561                 Skip ->
1562                   postprocess_children (Some child) l'
1563            )
1564     )
1565   in
1566   let base' = map_rec None base None in
1567   try post None base' None with Skip -> raise Not_found
1568 ;;
1569
1570
1571 let iter_tree ?(pre=(fun x -> ())) ?(post=(fun x -> ())) base =
1572   let rec iter_rec n =
1573     (try
1574       pre n;
1575       let children = n # sub_nodes in
1576       iter_children children;
1577       post n
1578     with
1579         Skip -> raise Not_found
1580     )
1581   and iter_children l =
1582     match l with
1583         [] -> []
1584       | child :: l' ->
1585           (try
1586              iter_rec child;
1587              iter_children l'
1588            with
1589                Not_found ->
1590                  iter_children l'
1591           )
1592   in
1593   iter_rec base
1594 ;;
1595
1596
1597 let iter_tree_sibl ?(pre=(fun _ _ _ -> ())) ?(post=(fun _ _ _ -> ())) base =
1598   let rec iter_rec l n r =
1599     (try
1600       pre l n r;
1601       let children = n # sub_nodes in
1602       iter_children None children;
1603       post l n r
1604     with
1605         Skip -> raise Not_found
1606     )
1607   and iter_children predecessor l =
1608     (match l with
1609          [] -> []
1610        | child :: l' ->
1611            let successor =
1612              match l' with
1613                  []    -> None
1614               | x :: _ -> Some x in
1615            (try
1616               iter_rec predecessor child successor;
1617               iter_children (Some child) l'
1618             with
1619                 Not_found ->
1620                   iter_children (Some child) l'
1621            )
1622     )
1623   in
1624   iter_rec None base None
1625 ;;
1626
1627
1628 let compare a b =
1629   let rec cmp p1 p2 =
1630     match p1, p2 with
1631         [], []         -> 0
1632       | [], _          -> -1
1633       | _, []          -> 1
1634       | x::p1', y::p2' -> if x = y then cmp p1' p2' else x - y
1635   in
1636
1637   let a_path = a # node_path in
1638   let b_path = b # node_path in
1639
1640   cmp a_path b_path
1641 ;;
1642
1643
1644 type 'ext ord_index = ('ext node, int) Hashtbl.t;;
1645
1646 let create_ord_index base =
1647   let n = ref 0 in
1648   iter_tree ~pre:(fun _ -> incr n) base;
1649   let idx = Hashtbl.create !n in
1650   let k = ref 0 in
1651   iter_tree ~pre:(fun node -> Hashtbl.add idx node !k; incr k) base;
1652   idx
1653 ;;
1654
1655
1656 let ord_number idx node =
1657   Hashtbl.find idx node
1658 ;;
1659
1660 let ord_compare idx a b =
1661   let ord_a = Hashtbl.find idx a in
1662   let ord_b = Hashtbl.find idx b in
1663   ord_a - ord_b
1664 ;;
1665
1666 class ['ext] document the_warner =
1667   object (self)
1668     val mutable xml_version = "1.0"
1669     val mutable dtd = (None : dtd option)
1670     val mutable root = (None : 'ext node option)
1671
1672     val pinstr = lazy (Hashtbl.create 10 : (string,proc_instruction) Hashtbl.t)
1673     val warner = (the_warner : collect_warnings)
1674
1675     method init_xml_version s =
1676       if s <> "1.0" then
1677         warner # warn ("XML version '" ^ s ^ "' not supported");
1678       xml_version <- s
1679
1680     method init_root r =
1681       let dtd_r = r # dtd in
1682       match r # node_type with
1683
1684         (**************** CASE: We have a super root element ***************)
1685
1686         | T_super_root ->
1687             if not (dtd_r # arbitrary_allowed) then begin
1688               match dtd_r # root with
1689                   Some declared_root_element_name ->
1690                     let real_root_element =
1691                       try
1692                         List.find
1693                           (fun r' ->
1694                              match r' # node_type with
1695                                | T_element _     -> true
1696                                | _               -> false)
1697                           (r # sub_nodes)
1698                       with
1699                           Not_found ->
1700                             failwith "Pxp_document.document#init_root: Super root does not contain root element"
1701                               (* TODO: Check also that there is at most one
1702                                * element in the super root node
1703                                *)
1704
1705                     in
1706                     let real_root_element_name =
1707                       match real_root_element # node_type with
1708                           T_element name -> name
1709                         | _              -> assert false
1710                     in
1711                     if real_root_element_name <> declared_root_element_name then
1712                       raise
1713                         (Validation_error ("The root element is `" ^
1714                                            real_root_element_name ^
1715                                            "' but is declared as `" ^
1716                                            declared_root_element_name))
1717                 | None -> ()
1718             end;
1719             (* All is okay, so store dtd and root node: *)
1720             dtd <- Some dtd_r;
1721             root <- Some r
1722
1723         (**************** CASE: No super root element **********************)
1724
1725         | T_element root_element_name ->
1726             if not (dtd_r # arbitrary_allowed) then begin
1727               match dtd_r # root with
1728                   Some declared_root_element_name ->
1729                     if root_element_name <> declared_root_element_name then
1730                       raise
1731                         (Validation_error ("The root element is `" ^
1732                                            root_element_name ^
1733                                            "' but is declared as `" ^
1734                                            declared_root_element_name))
1735                 | None ->
1736                     (* This may happen if you initialize your DTD yourself.
1737                      * The value 'None' means that the method 'set_root' was
1738                      * never called for the DTD; we interpret it here as:
1739                      * The root element does not matter.
1740                      *)
1741                     ()
1742             end;
1743             (* All is okay, so store dtd and root node: *)
1744             dtd <- Some dtd_r;
1745             root <- Some r
1746
1747         | _ ->
1748             failwith "Pxp_document.document#init_root: the root node must be an element or super-root"
1749
1750     method xml_version = xml_version
1751
1752     method xml_standalone =
1753       match dtd with
1754           None -> false
1755         | Some d -> d # standalone_declaration
1756
1757     method dtd =
1758       match dtd with
1759           None -> failwith "Pxp_document.document#dtd: Document has no DTD"
1760         | Some d -> d
1761
1762     method encoding =
1763       match dtd with
1764           None -> failwith "Pxp_document.document#encoding: Document has no DTD"
1765         | Some d -> d # encoding
1766
1767     method root =
1768       match root with
1769           None -> failwith "Pxp_document.document#root: Document has no root element"
1770         | Some r -> r
1771
1772     method add_pinstr pi =
1773       begin match dtd with
1774           None -> ()
1775         | Some d ->
1776             if pi # encoding <> d # encoding then
1777               failwith "Pxp_document.document # add_pinstr: Inconsistent encodings";
1778       end;
1779       let name = pi # target in
1780       Hashtbl.add (Lazy.force pinstr) name pi
1781
1782     method pinstr name =
1783       Hashtbl.find_all (Lazy.force pinstr) name
1784
1785     method pinstr_names =
1786       let l = ref [] in
1787       Hashtbl.iter
1788         (fun n _ -> l := n :: !l)
1789         (Lazy.force pinstr);
1790       !l
1791
1792     method write os enc =
1793       let encoding = self # encoding in
1794       let wms =
1795         write_markup_string ~from_enc:encoding ~to_enc:enc os in
1796
1797       let r = self # root in
1798       wms ("<?xml version='1.0' encoding='" ^
1799            Netconversion.string_of_encoding enc ^
1800            "'?>\n");
1801       ( match self # dtd # root with
1802             None ->
1803               self # dtd # write os enc false
1804           | Some _ ->
1805               self # dtd # write os enc true
1806       );
1807       Hashtbl.iter
1808         (fun n pi ->
1809            pi # write os enc
1810         )
1811         (Lazy.force pinstr);
1812       r # write os enc;
1813       wms "\n";
1814
1815     method write_compact_as_latin1 os =
1816       self # write os `Enc_iso88591
1817
1818   end
1819 ;;
1820
1821
1822 (* ======================================================================
1823  * History:
1824  *
1825  * $Log$
1826  * Revision 1.1  2000/11/17 09:57:29  lpadovan
1827  * Initial revision
1828  *
1829  * Revision 1.14  2000/08/30 15:47:52  gerd
1830  *      Implementation of pxp_document.mli rev 1.10.
1831  *
1832  * Revision 1.13  2000/08/26 23:29:10  gerd
1833  *      Implementations for the changed in rev 1.9 of pxp_document.mli.
1834  *
1835  * Revision 1.12  2000/08/18 20:14:00  gerd
1836  *      New node_types: T_super_root, T_pinstr, T_comment, (T_attribute),
1837  * (T_none), (T_namespace).
1838  *
1839  * Revision 1.11  2000/08/14 22:24:55  gerd
1840  *      Moved the module Pxp_encoding to the netstring package under
1841  * the new name Netconversion.
1842  *
1843  * Revision 1.10  2000/07/23 02:16:34  gerd
1844  *      Support for DFAs.
1845  *
1846  * Revision 1.9  2000/07/16 19:37:09  gerd
1847  *      Simplification.
1848  *
1849  * Revision 1.8  2000/07/16 17:50:01  gerd
1850  *      Fixes in 'write'
1851  *
1852  * Revision 1.7  2000/07/16 16:34:41  gerd
1853  *      New method 'write', the successor of 'write_compact_as_latin1'.
1854  *
1855  * Revision 1.6  2000/07/14 13:56:11  gerd
1856  *      Added methods id_attribute_name, id_attribute_value,
1857  * idref_attribute_names.
1858  *
1859  * Revision 1.5  2000/07/09 17:51:14  gerd
1860  *      Element nodes can store positions.
1861  *
1862  * Revision 1.4  2000/07/08 23:04:06  gerd
1863  *      [Merging 0.2.10:] Bugfix: allow_undeclared_attribute
1864  *
1865  * Revision 1.3  2000/07/04 22:10:06  gerd
1866  *      Implemented rev 1.3 of pxp_document.mli in a straight-
1867  * forward fashion.
1868  *
1869  * Revision 1.2  2000/06/14 22:19:06  gerd
1870  *      Added checks such that it is impossible to mix encodings.
1871  *
1872  * Revision 1.1  2000/05/29 23:48:38  gerd
1873  *      Changed module names:
1874  *              Markup_aux          into Pxp_aux
1875  *              Markup_codewriter   into Pxp_codewriter
1876  *              Markup_document     into Pxp_document
1877  *              Markup_dtd          into Pxp_dtd
1878  *              Markup_entity       into Pxp_entity
1879  *              Markup_lexer_types  into Pxp_lexer_types
1880  *              Markup_reader       into Pxp_reader
1881  *              Markup_types        into Pxp_types
1882  *              Markup_yacc         into Pxp_yacc
1883  * See directory "compatibility" for (almost) compatible wrappers emulating
1884  * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
1885  *
1886  * ======================================================================
1887  * Old logs from markup_document.ml:
1888  *
1889  * Revision 1.19  2000/05/27 19:14:42  gerd
1890  *      value_of_attribute: this function has been moved to
1891  * markup_aux.ml.
1892  *
1893  *      Added the following checks whether there is a violation
1894  * against the standalone declaration:
1895  *      - Externally declared elements with regexp content model
1896  *        must not contain extra white space
1897  *      - The effect of normalization of externally declared attributes
1898  *        must not depend on the type of the attributes
1899  *      - Declared default values of externally declared attributes
1900  *        must not have an effect on the value of the attributes.
1901  *
1902  *      Removed the method init_xml_standalone. It is now stored in
1903  * the DTD whether there is a standalone declaration.
1904  *
1905  * Revision 1.18  2000/05/20 20:31:40  gerd
1906  *      Big change: Added support for various encodings of the
1907  * internal representation.
1908  *
1909  * Revision 1.17  2000/05/06 23:12:20  gerd
1910  *      Allow undeclared attributes.
1911  *
1912  * Revision 1.16  2000/05/01 20:42:28  gerd
1913  *      New method write_compact_as_latin1.
1914  *
1915  * Revision 1.15  2000/04/30 18:15:22  gerd
1916  *      In function validate_content: Special handling of the pseudo
1917  * nodes "-pi" and "-vr".
1918  *      Method init_root, class document: Recognizes whether the
1919  * root is virtual or real. The check on the root element name is different
1920  * in each case.
1921  *      New method keep_always_whitespace_mode: Turns a special mode
1922  * on in which ignorable whitespace is included into the document.
1923  *
1924  * Revision 1.14  2000/03/11 22:58:15  gerd
1925  *      Updated to support Markup_codewriter.
1926  *
1927  * Revision 1.13  2000/01/27 21:51:56  gerd
1928  *      Added method 'attributes'.
1929  *
1930  * Revision 1.12  2000/01/27 21:19:34  gerd
1931  *      Added methods.
1932  *      Bugfix: 'orphaned_clone' performs now really a clone.
1933  *
1934  * Revision 1.11  2000/01/20 21:57:58  gerd
1935  *      Bugfix: method set_nodes does no longer add the new subnodes
1936  * in the reverse order.
1937  *
1938  * Revision 1.10  1999/12/17 21:35:37  gerd
1939  *      Bugfix: If the name of the root element is not specified in
1940  * the DTD, the document does not check whether the root element is a
1941  * specific element.
1942  *
1943  * Revision 1.9  1999/11/09 22:22:01  gerd
1944  *      The "document" classes now checks that the root element is the
1945  * same as the declared root element. Thanks to Claudio Sacerdoti Coen
1946  * for his bug report.
1947  *
1948  * Revision 1.8  1999/09/01 22:51:40  gerd
1949  *      Added methods to store processing instructions.
1950  *
1951  * Revision 1.7  1999/09/01 16:19:18  gerd
1952  *      Added some warnings.
1953  *      If an element type has the content model EMPTY, it is now strictly
1954  * checked that the element instance is really empty. Especially, white space
1955  * is NOT allowed in such instances.
1956  *
1957  * Revision 1.6  1999/08/19 21:58:59  gerd
1958  *      Added method "reset_finder". This is not very convincing, but
1959  * currently the simplest way to update the ID hash table.
1960  *
1961  * Revision 1.5  1999/08/19 01:08:15  gerd
1962  *      Added method "find" that searches node by ID in the whole
1963  * tree.
1964  *      Bugfix: After the extension has been cloned, the "set_node" method
1965  * is invoked telling the clone to which node it is associated.
1966  *
1967  * Revision 1.4  1999/08/15 13:52:52  gerd
1968  *      Bugfix: WF_error "Attribute x occurs twice in element [unnamed]"
1969  * no longer possible; instead of "[unnamed]" the actual name is printed.
1970  *      Improved some of the error messages.
1971  *
1972  * Revision 1.3  1999/08/15 02:19:01  gerd
1973  *      If the DTD allows arbitrary elements, unknown elements are not
1974  * rejected.
1975  *
1976  * Revision 1.2  1999/08/11 14:54:23  gerd
1977  *      Optimizations: The hashtable for the 'pinstr' variable is only
1978  * created on demand. -- The 'only_whitespace' function uses a simple "for"
1979  * loop is the string is small and a lexer if the string is big.
1980  *
1981  * Revision 1.1  1999/08/10 00:35:50  gerd
1982  *      Initial revision.
1983  *
1984  *
1985  *)