helm/DEVEL/pxp/pxp/pxp_reader.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 exception Not_competent;;
   9 exception Not_resolvable of exn;;
  10
  11 class type resolver =
  12   object
  13     method init_rep_encoding : rep_encoding -> unit
  14     method init_warner : collect_warnings -> unit
  15     method rep_encoding : rep_encoding
  16     method open_in : ext_id -> Lexing.lexbuf
  17     method close_in : unit
  18     method close_all : unit
  19     method change_encoding : string -> unit
  20     method clone : resolver
  21   end
  22 ;;
  23
  24
  25 class virtual resolve_general
  26  =
  27   object (self)
  28     val mutable internal_encoding = `Enc_utf8
  29
  30     val mutable encoding = `Enc_utf8
  31     val mutable encoding_requested = false
  32
  33     val mutable warner = new drop_warnings
  34
  35     val mutable enc_initialized = false
  36     val mutable wrn_initialized = false
  37
  38     val mutable clones = []
  39
  40     method init_rep_encoding e =
  41       internal_encoding <- e;
  42       enc_initialized <- true;
  43
  44     method init_warner w =
  45       warner <- w;
  46       wrn_initialized <- true;
  47
  48     method rep_encoding = (internal_encoding :> rep_encoding)
  49
  50 (*
  51     method clone =
  52       ( {< encoding = `Enc_utf8;
  53            encoding_requested = false;
  54         >}
  55         : # resolver :> resolver )
  56 *)
  57
  58     method private warn (k:int) =
  59       (* Called if a character not representable has been found.
  60        * k is the character code.
  61        *)
  62         if k < 0xd800 or (k >= 0xe000 & k <= 0xfffd) or
  63            (k >= 0x10000 & k <= 0x10ffff) then begin
  64              warner # warn ("Code point cannot be represented: " ^ string_of_int k);
  65            end
  66         else
  67           raise (WF_error("Code point " ^ string_of_int k ^
  68                     " outside the accepted range of code points"))
  69
  70
  71     method private autodetect s =
  72       (* s must be at least 4 bytes long. The slot 'encoding' is
  73        * set to:
  74        * "UTF-16-BE": UTF-16/UCS-2 encoding big endian
  75        * "UTF-16-LE": UTF-16/UCS-2 encoding little endian
  76        * "UTF-8":     UTF-8 encoding
  77        *)
  78       if String.length s < 4 then
  79         encoding <- `Enc_utf8
  80       else if String.sub s 0 2 = "\254\255" then
  81         encoding <- `Enc_utf16
  82           (* Note: Netconversion.recode will detect the big endianess, too *)
  83       else if String.sub s 0 2 = "\255\254" then
  84         encoding <- `Enc_utf16
  85           (* Note: Netconversion.recode will detect the little endianess, too *)
  86       else
  87         encoding <- `Enc_utf8
  88
  89
  90     method private virtual next_string : string -> int -> int -> int
  91     method private virtual init_in : ext_id -> unit
  92     method virtual close_in : unit
  93
  94     method close_all =
  95       List.iter (fun r -> r # close_in) clones
  96
  97     method open_in xid =
  98       assert(enc_initialized && wrn_initialized);
  99
 100       encoding <- `Enc_utf8;
 101       encoding_requested <- false;
 102       self # init_in xid;         (* may raise Not_competent *)
 103       (* init_in: may already set 'encoding' *)
 104
 105       let buffer_max = 512 in
 106       let buffer = String.make buffer_max ' ' in
 107       let buffer_len = ref 0 in
 108       let buffer_end = ref false in
 109       let fillup () =
 110         if not !buffer_end & !buffer_len < buffer_max then begin
 111           let l =
 112             self # next_string buffer !buffer_len (buffer_max - !buffer_len) in
 113           if l = 0 then
 114             buffer_end := true
 115           else begin
 116             buffer_len := !buffer_len + l
 117           end
 118         end
 119       in
 120       let consume n =
 121         let l = !buffer_len - n in
 122         String.blit buffer n buffer 0 l;
 123         buffer_len := l
 124       in
 125
 126       fillup();
 127       if not encoding_requested then self # autodetect buffer;
 128
 129       Lexing.from_function
 130         (fun s n ->
 131            (* TODO: if encoding = internal_encoding, it is possible to
 132             * avoid copying buffer to s because s can be directly used
 133             * as buffer.
 134             *)
 135
 136            fillup();
 137            if !buffer_len = 0 then
 138              0
 139            else begin
 140              let m_in  = !buffer_len in
 141              let m_max = if encoding_requested then n else 1 in
 142              let n_in, n_out, encoding' =
 143                if encoding = (internal_encoding : rep_encoding :> encoding) &&
 144                   encoding_requested
 145                then begin
 146                  (* Special case encoding = internal_encoding *)
 147                  String.blit buffer 0 s 0 m_in;
 148                  m_in, m_in, encoding
 149                end
 150                else
 151                  Netconversion.recode
 152                    ~in_enc:encoding
 153                    ~in_buf:buffer
 154                    ~in_pos:0
 155                    ~in_len:m_in
 156                    ~out_enc:(internal_encoding : rep_encoding :> encoding)
 157                    ~out_buf:s
 158                    ~out_pos:0
 159                    ~out_len:n
 160                    ~max_chars:m_max
 161                    ~subst:(fun k -> self # warn k; "")
 162              in
 163              if n_in = 0 then
 164                (* An incomplete character at the end of the stream: *)
 165                raise Netconversion.Malformed_code;
 166                (* failwith "Badly encoded character"; *)
 167              encoding <- encoding';
 168              consume n_in;
 169              assert(n_out <> 0);
 170              n_out
 171            end)
 172
 173     method change_encoding enc =
 174       if not encoding_requested then begin
 175         if enc <> "" then begin
 176           match Netconversion.encoding_of_string enc with
 177               `Enc_utf16 ->
 178                 (match encoding with
 179                      (`Enc_utf16_le | `Enc_utf16_be) -> ()
 180                    | `Enc_utf16 -> assert false
 181                    | _ ->
 182                        raise(WF_error "Encoding of data stream and encoding declaration mismatch")
 183                 )
 184             | e ->
 185                 encoding <- e
 186         end;
 187         (* else: the autodetected encoding counts *)
 188         encoding_requested <- true;
 189       end;
 190   end
 191 ;;
 192
 193
 194 class resolve_read_any_channel ?(auto_close=true) ~channel_of_id =
 195   object (self)
 196     inherit resolve_general as super
 197
 198     val f_open = channel_of_id
 199     val mutable current_channel = None
 200     val auto_close = auto_close
 201
 202     method private init_in (id:ext_id) =
 203       if current_channel <> None then
 204         failwith "Pxp_reader.resolve_read_any_channel # init_in";
 205       let ch, enc_opt = f_open id in       (* may raise Not_competent *)
 206       begin match enc_opt with
 207           None     -> ()
 208         | Some enc -> encoding <- enc; encoding_requested <- true
 209       end;
 210       current_channel <- Some ch;
 211
 212     method private next_string s ofs len =
 213       match current_channel with
 214           None -> failwith "Pxp_reader.resolve_read_any_channel # next_string"
 215         | Some ch ->
 216             input ch s ofs len
 217
 218     method close_in =
 219       match current_channel with
 220           None -> ()
 221         | Some ch ->
 222             if auto_close then close_in ch;
 223             current_channel <- None
 224
 225     method clone =
 226       let c = new resolve_read_any_channel
 227                 ?auto_close:(Some auto_close) f_open in
 228       c # init_rep_encoding internal_encoding;
 229       c # init_warner warner;
 230       clones <- c :: clones;
 231       (c :> resolver)
 232
 233   end
 234 ;;
 235
 236
 237 class resolve_read_this_channel1 is_stale ?id ?fixenc ?auto_close ch =
 238
 239   let getchannel = ref (fun xid -> assert false) in
 240
 241   object (self)
 242     inherit resolve_read_any_channel
 243               ?auto_close:auto_close
 244               (fun xid -> !getchannel xid)
 245               as super
 246
 247     val mutable is_stale = is_stale
 248       (* The channel can only be read once. To avoid that the channel
 249        * is opened several times, the flag 'is_stale' is set after the
 250        * first time.
 251        *)
 252
 253     val fixid = id
 254     val fixenc = fixenc
 255     val fixch = ch
 256
 257     initializer
 258       getchannel := self # getchannel
 259
 260     method private getchannel xid =
 261       begin match fixid with
 262           None -> ()
 263         | Some bound_xid ->
 264             if xid <> bound_xid then raise Not_competent
 265       end;
 266       ch, fixenc
 267
 268     method private init_in (id:ext_id) =
 269       if is_stale then
 270         raise Not_competent
 271       else begin
 272         super # init_in id;
 273         is_stale <- true
 274       end
 275
 276     method close_in =
 277       current_channel <- None
 278
 279     method clone =
 280       let c = new resolve_read_this_channel1
 281                 is_stale
 282                 ?id:fixid ?fixenc:fixenc ?auto_close:(Some auto_close) fixch
 283       in
 284       c # init_rep_encoding internal_encoding;
 285       c # init_warner warner;
 286       clones <- c :: clones;
 287       (c :> resolver)
 288
 289   end
 290 ;;
 291
 292
 293 class resolve_read_this_channel =
 294   resolve_read_this_channel1 false
 295 ;;
 296
 297
 298 class resolve_read_any_string ~string_of_id =
 299   object (self)
 300     inherit resolve_general as super
 301
 302     val f_open = string_of_id
 303     val mutable current_string = None
 304     val mutable current_pos    = 0
 305
 306     method private init_in (id:ext_id) =
 307       if current_string <> None then
 308         failwith "Pxp_reader.resolve_read_any_string # init_in";
 309       let s, enc_opt = f_open id in       (* may raise Not_competent *)
 310       begin match enc_opt with
 311           None     -> ()
 312         | Some enc -> encoding <- enc; encoding_requested <- true
 313       end;
 314       current_string <- Some s;
 315       current_pos    <- 0;
 316
 317     method private next_string s ofs len =
 318       match current_string with
 319           None -> failwith "Pxp_reader.resolve_read_any_string # next_string"
 320         | Some str ->
 321             let l = min len (String.length str - current_pos) in
 322             String.blit str current_pos s ofs l;
 323             current_pos <- current_pos + l;
 324             l
 325
 326     method close_in =
 327       match current_string with
 328           None -> ()
 329         | Some _ ->
 330             current_string <- None
 331
 332     method clone =
 333       let c = new resolve_read_any_string f_open in
 334       c # init_rep_encoding internal_encoding;
 335       c # init_warner warner;
 336       clones <- c :: clones;
 337       (c :> resolver)
 338   end
 339 ;;
 340
 341
 342 class resolve_read_this_string1 is_stale ?id ?fixenc str =
 343
 344   let getstring = ref (fun xid -> assert false) in
 345
 346   object (self)
 347     inherit resolve_read_any_string (fun xid -> !getstring xid) as super
 348
 349     val is_stale = is_stale
 350       (* For some reasons, it is not allowed to open a clone of the resolver
 351        * a second time when the original resolver is already open.
 352        *)
 353
 354     val fixid = id
 355     val fixenc = fixenc
 356     val fixstr = str
 357
 358     initializer
 359       getstring := self # getstring
 360
 361     method private getstring xid =
 362       begin match fixid with
 363           None -> ()
 364         | Some bound_xid ->
 365             if xid <> bound_xid then raise Not_competent
 366       end;
 367       fixstr, fixenc
 368
 369
 370     method private init_in (id:ext_id) =
 371       if is_stale then
 372         raise Not_competent
 373       else
 374         super # init_in id
 375
 376     method clone =
 377       let c = new resolve_read_this_string1
 378                 (is_stale or current_string <> None)
 379                 ?id:fixid ?fixenc:fixenc fixstr
 380       in
 381       c # init_rep_encoding internal_encoding;
 382       c # init_warner warner;
 383       clones <- c :: clones;
 384       (c :> resolver)
 385   end
 386 ;;
 387
 388
 389 class resolve_read_this_string =
 390   resolve_read_this_string1 false
 391 ;;
 392
 393
 394 class resolve_read_url_channel
 395   ?(base_url = Neturl.null_url)
 396   ?auto_close
 397   ~url_of_id
 398   ~channel_of_url
 399
 400   : resolver
 401   =
 402
 403   let getchannel = ref (fun xid -> assert false) in
 404
 405   object (self)
 406     inherit resolve_read_any_channel
 407               ?auto_close:auto_close
 408               (fun xid -> !getchannel xid)
 409               as super
 410
 411     val base_url = base_url
 412     val mutable own_url = Neturl.null_url
 413
 414     val url_of_id = url_of_id
 415     val channel_of_url = channel_of_url
 416
 417
 418     initializer
 419       getchannel := self # getchannel
 420
 421     method private getchannel xid =
 422       let rel_url = url_of_id xid in    (* may raise Not_competent *)
 423
 424       try
 425         (* Now compute the absolute URL: *)
 426         let abs_url = Neturl.apply_relative_url base_url rel_url in
 427                       (* may raise Malformed_URL *)
 428
 429         (* Simple check whether 'abs_url' is really absolute: *)
 430         if not(Neturl.url_provides ~scheme:true abs_url)
 431         then raise Not_competent;
 432
 433         own_url <- abs_url;
 434         (* FIXME: Copy 'abs_url' ? *)
 435
 436         (* Get and return the channel: *)
 437         channel_of_url abs_url            (* may raise Not_competent *)
 438       with
 439           Neturl.Malformed_URL -> raise (Not_resolvable Neturl.Malformed_URL)
 440         | Not_competent        -> raise (Not_resolvable Not_found)
 441
 442     method clone =
 443       let c =
 444         new resolve_read_url_channel
 445           ?base_url:(Some own_url)
 446           ?auto_close:(Some auto_close)
 447           ~url_of_id:url_of_id
 448           ~channel_of_url:channel_of_url
 449       in
 450       c # init_rep_encoding internal_encoding;
 451       c # init_warner warner;
 452       clones <- c :: clones;
 453       (c :> resolve_read_url_channel)
 454   end
 455 ;;
 456
 457
 458 type spec = [ `Not_recognized | `Allowed | `Required ]
 459
 460 class resolve_as_file
 461   ?(file_prefix = (`Allowed :> spec))
 462   ?(host_prefix = (`Allowed :> spec))
 463   ?(system_encoding = `Enc_utf8)
 464   ?url_of_id:passed_url_of_id
 465   ?channel_of_url:passed_channel_of_url
 466   ()
 467   =
 468
 469   let url_syntax =
 470     let enable_if =
 471       function
 472           `Not_recognized  -> Neturl.Url_part_not_recognized
 473         | `Allowed         -> Neturl.Url_part_allowed
 474         | `Required        -> Neturl.Url_part_required
 475     in
 476     { Neturl.null_url_syntax with
 477         Neturl.url_enable_scheme = enable_if file_prefix;
 478         Neturl.url_enable_host   = enable_if host_prefix;
 479         Neturl.url_enable_path   = Neturl.Url_part_required;
 480         Neturl.url_accepts_8bits = true;
 481     }
 482   in
 483
 484   let base_url_syntax =
 485     { Neturl.null_url_syntax with
 486         Neturl.url_enable_scheme = Neturl.Url_part_required;
 487         Neturl.url_enable_host   = Neturl.Url_part_allowed;
 488         Neturl.url_enable_path   = Neturl.Url_part_required;
 489         Neturl.url_accepts_8bits = true;
 490     }
 491   in
 492
 493   let default_base_url =
 494     Neturl.make_url
 495       ~scheme: "file"
 496       ~host:   ""
 497       ~path:   (Neturl.split_path (Sys.getcwd() ^ "/"))
 498       base_url_syntax
 499   in
 500
 501   let file_url_of_id xid =
 502     let file_url_of_sysname sysname =
 503       (* By convention, we can assume that sysname is a URL conforming
 504        * to RFC 1738 with the exception that it may contain non-ASCII
 505        * UTF-8 characters.
 506        *)
 507       try
 508         Neturl.url_of_string url_syntax sysname
 509           (* may raise Malformed_URL *)
 510       with
 511           Neturl.Malformed_URL -> raise Not_competent
 512     in
 513     let url =
 514       match xid with
 515           Anonymous          -> raise Not_competent
 516         | Public (_,sysname) -> if sysname <> "" then file_url_of_sysname sysname
 517                                                  else raise Not_competent
 518         | System sysname     -> file_url_of_sysname sysname
 519     in
 520     let scheme =
 521       try Neturl.url_scheme url with Not_found -> "file" in
 522     let host =
 523       try Neturl.url_host url with Not_found -> "" in
 524
 525     if scheme <> "file" then raise Not_competent;
 526     if host <> "" && host <> "localhost" then raise Not_competent;
 527
 528     url
 529   in
 530
 531   let channel_of_file_url url =
 532     try
 533       let path_utf8 =
 534         try Neturl.join_path (Neturl.url_path ~encoded:false url)
 535         with Not_found -> raise Not_competent
 536       in
 537
 538       let path =
 539         Netconversion.recode_string
 540           ~in_enc:  `Enc_utf8
 541           ~out_enc: system_encoding
 542           path_utf8 in
 543         (* May raise Bad_character_stream *)
 544
 545       open_in_bin path, None
 546         (* May raise Sys_error *)
 547
 548     with
 549       | Netconversion.Malformed_code -> assert false
 550             (* should not happen *)
 551
 552   in
 553
 554   let url_of_id id =
 555     match passed_url_of_id with
 556         None ->
 557           file_url_of_id id
 558       | Some f ->
 559           begin
 560             try f id
 561             with
 562                 Not_competent -> file_url_of_id id
 563           end
 564   in
 565
 566   let channel_of_url url =
 567     match passed_channel_of_url with
 568         None ->
 569           channel_of_file_url url
 570       | Some f ->
 571           begin
 572             try f url
 573             with
 574                 Not_competent -> channel_of_file_url url
 575           end
 576   in
 577
 578   resolve_read_url_channel
 579     ~base_url:       default_base_url
 580     ~auto_close:     true
 581     ~url_of_id:      url_of_id
 582     ~channel_of_url: channel_of_url
 583 ;;
 584
 585
 586 class combine ?prefer rl =
 587   object (self)
 588     val prefered_resolver = prefer
 589     val resolvers = (rl : resolver list)
 590     val mutable internal_encoding = `Enc_utf8
 591     val mutable warner = new drop_warnings
 592     val mutable active_resolver = None
 593     val mutable clones = []
 594
 595     method init_rep_encoding enc =
 596       List.iter
 597         (fun r -> r # init_rep_encoding enc)
 598         rl;
 599       internal_encoding <- enc
 600
 601     method init_warner w =
 602       List.iter
 603         (fun r -> r # init_warner w)
 604         rl;
 605       warner <- w;
 606
 607     method rep_encoding = internal_encoding
 608       (* CAUTION: This may not be the truth! *)
 609
 610     method open_in xid =
 611       let rec find_competent_resolver rl =
 612         match rl with
 613             r :: rl' ->
 614               begin try
 615                 r, (r # open_in xid)
 616               with
 617                   Not_competent -> find_competent_resolver rl'
 618               end;
 619           | [] ->
 620               raise Not_competent
 621       in
 622
 623       if active_resolver <> None then failwith "Pxp_reader.combine # open_in";
 624       let r, lb =
 625         match prefered_resolver with
 626             None ->   find_competent_resolver resolvers
 627           | Some r -> find_competent_resolver (r :: resolvers)
 628       in
 629       active_resolver <- Some r;
 630       lb
 631
 632     method close_in =
 633       match active_resolver with
 634           None   -> ()
 635         | Some r -> r # close_in;
 636                     active_resolver <- None
 637
 638     method close_all =
 639       List.iter (fun r -> r # close_in) clones
 640
 641     method change_encoding (enc:string) =
 642       match active_resolver with
 643           None   -> failwith "Pxp_reader.combine # change_encoding"
 644         | Some r -> r # change_encoding enc
 645
 646     method clone =
 647       let c =
 648         match active_resolver with
 649             None   ->
 650               new combine ?prefer:None (List.map (fun q -> q # clone) resolvers)
 651           | Some r ->
 652               let r' = r # clone in
 653               new combine
 654                 ?prefer:(Some r')
 655                 (List.map
 656                    (fun q -> if q == r then r' else q # clone)
 657                    resolvers)
 658       in
 659       c # init_rep_encoding internal_encoding;
 660       c # init_warner warner;
 661       clones <- c :: clones;
 662       c
 663   end
 664
 665
 666
 667 (* ======================================================================
 668  * History:
 669  *
 670  * $Log$
 671  * Revision 1.1  2000/11/17 09:57:29  lpadovan
 672  * Initial revision
 673  *
 674  * Revision 1.9  2000/08/14 22:24:55  gerd
 675  *      Moved the module Pxp_encoding to the netstring package under
 676  * the new name Netconversion.
 677  *
 678  * Revision 1.8  2000/07/16 18:31:09  gerd
 679  *      The exception Illegal_character has been dropped.
 680  *
 681  * Revision 1.7  2000/07/09 15:32:01  gerd
 682  *      Fix in resolve_this_channel, resolve_this_string
 683  *
 684  * Revision 1.6  2000/07/09 01:05:33  gerd
 685  *      New methode 'close_all' that closes the clones, too.
 686  *
 687  * Revision 1.5  2000/07/08 16:24:56  gerd
 688  *      Introduced the exception 'Not_resolvable' to indicate that
 689  * 'combine' should not try the next resolver of the list.
 690  *
 691  * Revision 1.4  2000/07/06 23:04:46  gerd
 692  *      Quick fix for 'combine': The active resolver is "prefered",
 693  * but the other resolvers are also used.
 694  *
 695  * Revision 1.3  2000/07/06 21:43:45  gerd
 696  *      Fix: Public(_,name) is now treated as System(name) if
 697  * name is non-empty.
 698  *
 699  * Revision 1.2  2000/07/04 22:13:30  gerd
 700  *      Implemented the new API rev. 1.2 of pxp_reader.mli.
 701  *
 702  * Revision 1.1  2000/05/29 23:48:38  gerd
 703  *      Changed module names:
 704  *              Markup_aux          into Pxp_aux
 705  *              Markup_codewriter   into Pxp_codewriter
 706  *              Markup_document     into Pxp_document
 707  *              Markup_dtd          into Pxp_dtd
 708  *              Markup_entity       into Pxp_entity
 709  *              Markup_lexer_types  into Pxp_lexer_types
 710  *              Markup_reader       into Pxp_reader
 711  *              Markup_types        into Pxp_types
 712  *              Markup_yacc         into Pxp_yacc
 713  * See directory "compatibility" for (almost) compatible wrappers emulating
 714  * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
 715  *
 716  * ======================================================================
 717  * Old logs from markup_reader.ml:
 718  *
 719  * Revision 1.3  2000/05/29 21:14:57  gerd
 720  *      Changed the type 'encoding' into a polymorphic variant.
 721  *
 722  * Revision 1.2  2000/05/20 20:31:40  gerd
 723  *      Big change: Added support for various encodings of the
 724  * internal representation.
 725  *
 726  * Revision 1.1  2000/03/13 23:41:44  gerd
 727  *      Initial revision; this code was formerly part of Markup_entity.
 728  *
 729  *
 730  *)