]> matita.cs.unibo.it Git - helm.git/blob - pxp/csc_pxp_reader.ml
made executable again
[helm.git] / pxp / csc_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 ?(close=close_in) ~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 close = 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             close ch;
223             current_channel <- None
224
225     method clone =
226       let c = new resolve_read_any_channel
227                 ?close:(Some close) ~channel_of_id: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 ?close ch =
238
239   let getchannel = ref (fun xid -> assert false) in
240
241   object (self)
242     inherit resolve_read_any_channel
243               ?close
244               ~channel_of_id:(fun xid -> !getchannel xid)
245               ()
246               as super
247
248     val mutable is_stale = is_stale
249       (* The channel can only be read once. To avoid that the channel
250        * is opened several times, the flag 'is_stale' is set after the
251        * first time.
252        *)
253
254     val fixid = id
255     val fixenc = fixenc
256     val fixch = ch
257
258     initializer
259       getchannel := self # getchannel
260
261     method private getchannel xid =
262       begin match fixid with
263           None -> ()
264         | Some bound_xid ->
265             if xid <> bound_xid then raise Not_competent
266       end;
267       ch, fixenc
268
269     method private init_in (id:ext_id) =
270       if is_stale then
271         raise Not_competent
272       else begin
273         super # init_in id;
274         is_stale <- true
275       end
276
277     method close_in =
278       current_channel <- None
279
280     method clone =
281       let c = new resolve_read_this_channel1
282                 is_stale
283                 ?id:fixid ?fixenc:fixenc ?close:(Some close) fixch
284       in
285       c # init_rep_encoding internal_encoding;
286       c # init_warner warner;
287       clones <- c :: clones;
288       (c :> resolver)
289
290   end
291 ;;
292
293
294 class resolve_read_this_channel =
295   resolve_read_this_channel1 false
296 ;;
297
298
299 class resolve_read_any_string ~string_of_id () =
300   object (self)
301     inherit resolve_general as super
302
303     val f_open = string_of_id
304     val mutable current_string = None
305     val mutable current_pos    = 0
306
307     method private init_in (id:ext_id) =
308       if current_string <> None then
309         failwith "Pxp_reader.resolve_read_any_string # init_in";
310       let s, enc_opt = f_open id in       (* may raise Not_competent *)
311       begin match enc_opt with
312           None     -> ()
313         | Some enc -> encoding <- enc; encoding_requested <- true
314       end;
315       current_string <- Some s;
316       current_pos    <- 0;
317
318     method private next_string s ofs len =
319       match current_string with
320           None -> failwith "Pxp_reader.resolve_read_any_string # next_string"
321         | Some str ->
322             let l = min len (String.length str - current_pos) in
323             String.blit str current_pos s ofs l;
324             current_pos <- current_pos + l;
325             l
326
327     method close_in =
328       match current_string with
329           None -> ()
330         | Some _ ->
331             current_string <- None
332
333     method clone =
334       let c = new resolve_read_any_string ~string_of_id:f_open () in
335       c # init_rep_encoding internal_encoding;
336       c # init_warner warner;
337       clones <- c :: clones;
338       (c :> resolver)
339   end
340 ;;
341
342
343 class resolve_read_this_string1 is_stale ?id ?fixenc str =
344
345   let getstring = ref (fun xid -> assert false) in
346
347   object (self)
348     inherit resolve_read_any_string (fun xid -> !getstring xid) () as super
349
350     val is_stale = is_stale
351       (* For some reasons, it is not allowed to open a clone of the resolver
352        * a second time when the original resolver is already open.
353        *)
354
355     val fixid = id
356     val fixenc = fixenc
357     val fixstr = str
358
359     initializer
360       getstring := self # getstring
361
362     method private getstring xid =
363       begin match fixid with
364           None -> ()
365         | Some bound_xid ->
366             if xid <> bound_xid then raise Not_competent
367       end;
368       fixstr, fixenc
369
370
371     method private init_in (id:ext_id) =
372       if is_stale then
373         raise Not_competent
374       else
375         super # init_in id
376
377     method clone =
378       let c = new resolve_read_this_string1
379                 (is_stale or current_string <> None)
380                 ?id:fixid ?fixenc:fixenc fixstr
381       in
382       c # init_rep_encoding internal_encoding;
383       c # init_warner warner;
384       clones <- c :: clones;
385       (c :> resolver)
386   end
387 ;;
388
389
390 class resolve_read_this_string =
391   resolve_read_this_string1 false
392 ;;
393
394
395 class resolve_read_url_channel
396   ?(base_url = Neturl.null_url)
397   ?close
398   ~url_of_id
399   ~channel_of_url
400   ()
401
402   : resolver
403   =
404
405   let getchannel = ref (fun xid -> assert false) in
406
407   object (self)
408     inherit resolve_read_any_channel
409               ?close
410               ~channel_of_id:(fun xid -> !getchannel xid)
411               ()
412               as super
413
414     val base_url = base_url
415     val mutable own_url = Neturl.null_url
416
417     val url_of_id = url_of_id
418     val channel_of_url = channel_of_url
419
420
421     initializer
422       getchannel := self # getchannel
423
424     method private getchannel xid =
425       let rel_url = url_of_id xid in    (* may raise Not_competent *)
426
427       try
428         (* Now compute the absolute URL: *)
429         let abs_url = 
430           if Neturl.url_provides ~scheme:true rel_url then
431             rel_url
432           else
433             Neturl.apply_relative_url base_url rel_url in
434             (* may raise Malformed_URL *)
435
436         (* Simple check whether 'abs_url' is really absolute: *)
437         if not(Neturl.url_provides ~scheme:true abs_url)
438         then raise Not_competent;
439
440         own_url <- abs_url;
441         (* FIXME: Copy 'abs_url' ? *)
442
443         (* Get and return the channel: *)
444         channel_of_url xid abs_url            (* may raise Not_competent *)
445       with
446           Neturl.Malformed_URL -> raise (Not_resolvable Neturl.Malformed_URL)
447         | Not_competent        -> raise (Not_resolvable Not_found)
448
449     method clone =
450       let c =
451         new resolve_read_url_channel
452           ?base_url:(Some own_url)
453           ?close:(Some close)
454           ~url_of_id:url_of_id
455           ~channel_of_url:channel_of_url
456           ()
457       in
458       c # init_rep_encoding internal_encoding;
459       c # init_warner warner;
460       clones <- c :: clones;
461       (c :> resolve_read_url_channel)
462   end
463 ;;
464
465
466 type spec = [ `Not_recognized | `Allowed | `Required ]
467
468 class resolve_as_file
469   ?(file_prefix = (`Allowed :> spec))
470   ?(host_prefix = (`Allowed :> spec))
471   ?(system_encoding = `Enc_utf8)
472   ?(map_private_id = (fun _ -> raise Not_competent))
473   ?(open_private_id = (fun _ -> raise Not_competent))
474   ()
475   =
476
477   let url_syntax =
478     let enable_if =
479       function
480           `Not_recognized  -> Neturl.Url_part_not_recognized
481         | `Allowed         -> Neturl.Url_part_allowed
482         | `Required        -> Neturl.Url_part_required
483     in
484     { Neturl.null_url_syntax with
485         Neturl.url_enable_scheme = enable_if file_prefix;
486         Neturl.url_enable_host   = enable_if host_prefix;
487         Neturl.url_enable_path   = Neturl.Url_part_required;
488         Neturl.url_accepts_8bits = true;
489     }
490   in
491
492   let base_url_syntax =
493     { Neturl.null_url_syntax with
494         Neturl.url_enable_scheme = Neturl.Url_part_required;
495         Neturl.url_enable_host   = Neturl.Url_part_allowed;
496         Neturl.url_enable_path   = Neturl.Url_part_required;
497         Neturl.url_accepts_8bits = true;
498     }
499   in
500
501   let default_base_url =
502     Neturl.make_url
503       ~scheme: "file"
504       ~host:   ""
505       ~path:   (Neturl.split_path (Sys.getcwd() ^ "/"))
506       base_url_syntax
507   in
508
509   let file_url_of_id xid =
510     let file_url_of_sysname sysname =
511       (* By convention, we can assume that sysname is a URL conforming
512        * to RFC 1738 with the exception that it may contain non-ASCII
513        * UTF-8 characters.
514        *)
515       try
516         Neturl.url_of_string url_syntax sysname
517           (* may raise Malformed_URL *)
518       with
519           Neturl.Malformed_URL -> raise Not_competent
520     in
521     let url =
522       match xid with
523           Anonymous          -> raise Not_competent
524         | Public (_,sysname) -> if sysname <> "" then file_url_of_sysname sysname
525                                                  else raise Not_competent
526         | System sysname     -> file_url_of_sysname sysname
527         | Private pid        -> map_private_id pid
528     in
529     let scheme =
530       try Neturl.url_scheme url with Not_found -> "file" in
531     let host =
532       try Neturl.url_host url with Not_found -> "" in
533
534     if scheme <> "file" then raise Not_competent;
535     if host <> "" && host <> "localhost" then raise Not_competent;
536
537     url
538   in
539
540   let channel_of_file_url xid url =
541     match xid with
542         Private pid -> open_private_id pid
543       | _ ->
544           ( try
545               let path_utf8 =
546                 try Neturl.join_path (Neturl.url_path ~encoded:false url)
547                 with Not_found -> raise Not_competent
548               in
549               
550               let path =
551                 Netconversion.recode_string
552                   ~in_enc:  `Enc_utf8
553                   ~out_enc: system_encoding
554                   path_utf8 in
555               (* May raise Malformed_code *)
556               
557               open_in_bin path, None
558                 (* May raise Sys_error *)
559                 
560             with
561               | Netconversion.Malformed_code -> assert false
562                 (* should not happen *)
563               | Sys_error _ as e ->
564                   raise (Not_resolvable e)
565           )
566   in
567
568   resolve_read_url_channel
569     ~base_url:       default_base_url
570     ~url_of_id:      file_url_of_id
571     ~channel_of_url: channel_of_file_url
572     ()
573 ;;
574
575
576 let make_file_url ?(system_encoding = `Enc_utf8) ?(enc = `Enc_utf8) filename =
577   let utf8_filename =
578     Netconversion.recode_string
579     ~in_enc: enc
580     ~out_enc: `Enc_utf8 
581       filename
582   in
583
584   let utf8_abs_filename =
585     if utf8_filename <> "" && utf8_filename.[0] = '/' then
586       utf8_filename
587     else
588       let cwd = Sys.getcwd() in
589       let cwd_utf8 =
590         Netconversion.recode_string
591         ~in_enc: system_encoding
592         ~out_enc: `Enc_utf8 in
593       cwd ^ "/" ^ utf8_filename
594   in
595   
596   let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
597   let url = Neturl.make_url
598             ~scheme:"file"
599             ~host:"localhost"
600             ~path:(Neturl.split_path utf8_abs_filename)
601               syntax
602   in
603   url
604 ;;
605
606
607 class lookup_public_id (catalog : (string * resolver) list) =
608   let norm_catalog =
609     List.map (fun (id,s) -> Pxp_aux.normalize_public_id id, s) catalog in
610 ( object (self)
611     val cat = norm_catalog
612     val mutable internal_encoding = `Enc_utf8
613     val mutable warner = new drop_warnings
614     val mutable active_resolver = None
615
616     method init_rep_encoding enc =
617       internal_encoding <- enc
618
619     method init_warner w =
620       warner <- w;
621
622     method rep_encoding = internal_encoding
623       (* CAUTION: This may not be the truth! *)
624
625     method open_in xid =
626
627       if active_resolver <> None then failwith "Pxp_reader.lookup_* # open_in";
628
629       let r =
630         match xid with
631             Public(pubid,_) ->
632               begin
633                 (* Search pubid in catalog: *)
634                 try
635                   let norm_pubid = Pxp_aux.normalize_public_id pubid in
636                   List.assoc norm_pubid cat
637                 with
638                     Not_found ->
639                       raise Not_competent
640               end
641           | _ ->
642               raise Not_competent
643       in
644
645       let r' = r # clone in
646       r' # init_rep_encoding internal_encoding;
647       r' # init_warner warner;
648       let lb = r' # open_in xid in   (* may raise Not_competent *)
649       active_resolver <- Some r';
650       lb
651
652     method close_in =
653       match active_resolver with
654           None   -> ()
655         | Some r -> r # close_in;
656                     active_resolver <- None
657
658     method close_all =
659       self # close_in
660
661     method change_encoding (enc:string) =
662       match active_resolver with
663           None   -> failwith "Pxp_reader.lookup_* # change_encoding"
664         | Some r -> r # change_encoding enc
665
666     method clone =
667       let c = new lookup_public_id cat in
668       c # init_rep_encoding internal_encoding;
669       c # init_warner warner;
670       c
671   end : resolver )
672 ;;
673
674
675 let lookup_public_id_as_file ?(fixenc:encoding option) catalog =
676   let ch_of_id filename id =
677     let ch = open_in_bin filename in  (* may raise Sys_error *)
678     ch, fixenc
679   in
680   let catalog' =
681     List.map
682       (fun (id,s) ->
683          (id, new resolve_read_any_channel (ch_of_id s) ())
684       )
685       catalog
686   in
687   new lookup_public_id catalog'
688 ;;
689
690
691 let lookup_public_id_as_string ?(fixenc:encoding option) catalog =
692    let catalog' =
693     List.map
694       (fun (id,s) ->
695          (id, new resolve_read_any_string (fun _ -> s, fixenc) ())
696       )
697       catalog
698   in
699   new lookup_public_id catalog'
700 ;;
701    
702
703 class lookup_system_id (catalog : (string * resolver) list) =
704 ( object (self)
705     val cat = catalog
706     val mutable internal_encoding = `Enc_utf8
707     val mutable warner = new drop_warnings
708     val mutable active_resolver = None
709
710     method init_rep_encoding enc =
711       internal_encoding <- enc
712
713     method init_warner w =
714       warner <- w;
715
716     method rep_encoding = internal_encoding
717       (* CAUTION: This may not be the truth! *)
718
719
720     method open_in xid =
721
722       if active_resolver <> None then failwith "Pxp_reader.lookup_system_id # open_in";
723
724       let lookup sysid =
725         try
726           List.assoc sysid cat
727         with
728             Not_found ->
729               raise Not_competent
730       in
731
732       let r =
733         match xid with
734             System sysid    -> lookup sysid
735           | Public(_,sysid) -> lookup sysid
736           | _               -> raise Not_competent
737       in
738
739       let r' = r # clone in
740       r' # init_rep_encoding internal_encoding;
741       r' # init_warner warner;
742       let lb = r' # open_in xid in   (* may raise Not_competent *)
743       active_resolver <- Some r';
744       lb
745
746
747     method close_in =
748       match active_resolver with
749           None   -> ()
750         | Some r -> r # close_in;
751                     active_resolver <- None
752
753     method close_all =
754       self # close_in
755
756     method change_encoding (enc:string) =
757       match active_resolver with
758           None   -> failwith "Pxp_reader.lookup_system # change_encoding"
759         | Some r -> r # change_encoding enc
760
761     method clone =
762       let c = new lookup_system_id cat in
763       c # init_rep_encoding internal_encoding;
764       c # init_warner warner;
765       c
766   end : resolver)
767 ;;
768
769
770 let lookup_system_id_as_file ?(fixenc:encoding option) catalog =
771   let ch_of_id filename id =
772     let ch = open_in_bin filename in  (* may raise Sys_error *)
773     ch, fixenc
774   in
775   let catalog' =
776     List.map
777       (fun (id,s) ->
778          (id, new resolve_read_any_channel (ch_of_id s) ())
779       )
780       catalog
781   in
782   new lookup_system_id catalog'
783 ;;
784
785
786 let lookup_system_id_as_string ?(fixenc:encoding option) catalog =
787    let catalog' =
788     List.map
789       (fun (id,s) ->
790          (id, new resolve_read_any_string (fun _ -> s, fixenc) ())
791       )
792       catalog
793   in
794   new lookup_system_id catalog'
795 ;;
796    
797
798 type combination_mode =
799     Public_before_system
800   | System_before_public
801 ;;
802
803
804 class combine ?prefer ?(mode = Public_before_system) rl =
805   object (self)
806     val prefered_resolver = prefer
807     val mode = mode
808     val resolvers = (rl : resolver list)
809     val mutable internal_encoding = `Enc_utf8
810     val mutable warner = new drop_warnings
811     val mutable active_resolver = None
812     val mutable clones = []
813
814     method init_rep_encoding enc =
815       List.iter
816         (fun r -> r # init_rep_encoding enc)
817         rl;
818       internal_encoding <- enc
819
820     method init_warner w =
821       List.iter
822         (fun r -> r # init_warner w)
823         rl;
824       warner <- w;
825
826     method rep_encoding = internal_encoding
827       (* CAUTION: This may not be the truth! *)
828
829     method open_in xid =
830       let rec find_competent_resolver_for xid' rl =
831         match rl with
832             r :: rl' ->
833               begin try
834                 r, (r # open_in xid')
835               with
836                   Not_competent -> find_competent_resolver_for xid' rl'
837               end;
838           | [] ->
839               raise Not_competent
840       in
841
842       let find_competent_resolver rl =
843         match xid with
844             Public(pubid,sysid) ->
845               ( match mode with
846                     Public_before_system ->
847                       ( try
848                           find_competent_resolver_for(Public(pubid,"")) rl
849                         with
850                             Not_competent ->
851                               find_competent_resolver_for(System sysid) rl
852                       )
853                   | System_before_public ->
854                       ( try
855                           find_competent_resolver_for(System sysid) rl
856                         with
857                             Not_competent ->
858                               find_competent_resolver_for(Public(pubid,"")) rl
859                       )
860               )
861           | other ->
862               find_competent_resolver_for other rl
863       in
864
865       if active_resolver <> None then failwith "Pxp_reader.combine # open_in";
866       let r, lb =
867         match prefered_resolver with
868             None ->   find_competent_resolver resolvers
869           | Some r -> find_competent_resolver (r :: resolvers)
870       in
871       active_resolver <- Some r;
872       lb
873
874     method close_in =
875       match active_resolver with
876           None   -> ()
877         | Some r -> r # close_in;
878                     active_resolver <- None
879
880     method close_all =
881       List.iter (fun r -> r # close_in) clones
882
883     method change_encoding (enc:string) =
884       match active_resolver with
885           None   -> failwith "Pxp_reader.combine # change_encoding"
886         | Some r -> r # change_encoding enc
887
888     method clone =
889       let c =
890         match active_resolver with
891             None   ->
892               new combine ?prefer:None ?mode:(Some mode) 
893                           (List.map (fun q -> q # clone) resolvers)
894           | Some r ->
895               let r' = r # clone in
896               new combine
897                 ?prefer:(Some r')
898                 ?mode:(Some mode)
899                 (List.map
900                    (fun q -> if q == r then r' else q # clone)
901                    resolvers)
902       in
903       c # init_rep_encoding internal_encoding;
904       c # init_warner warner;
905       clones <- c :: clones;
906       c
907   end
908
909
910
911 (* ======================================================================
912  * History:
913  *
914  * $Log$
915  * Revision 1.2  2002/01/29 14:44:29  sacerdot
916  * Ported to ocaml-3.04.
917  *
918  * Revision 1.1  2001/11/26 18:28:28  sacerdot
919  * HELM OCaml libraries with findlib support.
920  *
921  * Revision 1.1  2001/10/24 15:33:16  sacerdot
922  * New procedure to create metadata committed and old procedure removed.
923  * The new procedure is based on ocaml code and builds metadata for both
924  * forward and backward pointers. The old one was based on a stylesheet.
925  *
926  * Revision 1.16  2001/07/01 09:46:40  gerd
927  *      Fix: resolve_read_url_channel does not use the base_url if
928  * the current URL is already absolute
929  *
930  * Revision 1.15  2001/07/01 08:35:23  gerd
931  *      Instead of the ~auto_close argument, there is now a
932  * ~close argument for several functions/classes. This allows some
933  * additional action when the resolver is closed.
934  *
935  * Revision 1.14  2001/06/14 23:28:02  gerd
936  *      Fix: class combine works now with private IDs.
937  *
938  * Revision 1.13  2001/04/22 14:16:48  gerd
939  *      resolve_as_file: you can map private IDs to arbitrary channels.
940  *      resolve_read_url_channel: changed type of the channel_of_url
941  * argument (ext_id is also passed)
942  *      More examples and documentation.
943  *
944  * Revision 1.12  2001/04/21 17:40:48  gerd
945  *      Bugfix in 'combine'
946  *
947  * Revision 1.11  2001/04/03 20:22:44  gerd
948  *      New resolvers for catalogs of PUBLIC and SYSTEM IDs.
949  *      Improved "combine": PUBLIC and SYSTEM IDs are handled
950  * separately.
951  *      Rewritten from_file: Is now a simple application of the
952  * Pxp_reader classes and functions. (The same has still to be done
953  * for from_channel!)
954  *
955  * Revision 1.10  2001/02/01 20:38:49  gerd
956  *      New support for PUBLIC identifiers.
957  *
958  * Revision 1.9  2000/08/14 22:24:55  gerd
959  *      Moved the module Pxp_encoding to the netstring package under
960  * the new name Netconversion.
961  *
962  * Revision 1.8  2000/07/16 18:31:09  gerd
963  *      The exception Illegal_character has been dropped.
964  *
965  * Revision 1.7  2000/07/09 15:32:01  gerd
966  *      Fix in resolve_this_channel, resolve_this_string
967  *
968  * Revision 1.6  2000/07/09 01:05:33  gerd
969  *      New methode 'close_all' that closes the clones, too.
970  *
971  * Revision 1.5  2000/07/08 16:24:56  gerd
972  *      Introduced the exception 'Not_resolvable' to indicate that
973  * 'combine' should not try the next resolver of the list.
974  *
975  * Revision 1.4  2000/07/06 23:04:46  gerd
976  *      Quick fix for 'combine': The active resolver is "prefered",
977  * but the other resolvers are also used.
978  *
979  * Revision 1.3  2000/07/06 21:43:45  gerd
980  *      Fix: Public(_,name) is now treated as System(name) if
981  * name is non-empty.
982  *
983  * Revision 1.2  2000/07/04 22:13:30  gerd
984  *      Implemented the new API rev. 1.2 of pxp_reader.mli.
985  *
986  * Revision 1.1  2000/05/29 23:48:38  gerd
987  *      Changed module names:
988  *              Markup_aux          into Pxp_aux
989  *              Markup_codewriter   into Pxp_codewriter
990  *              Markup_document     into Pxp_document
991  *              Markup_dtd          into Pxp_dtd
992  *              Markup_entity       into Pxp_entity
993  *              Markup_lexer_types  into Pxp_lexer_types
994  *              Markup_reader       into Pxp_reader
995  *              Markup_types        into Pxp_types
996  *              Markup_yacc         into Pxp_yacc
997  * See directory "compatibility" for (almost) compatible wrappers emulating
998  * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
999  *
1000  * ======================================================================
1001  * Old logs from markup_reader.ml:
1002  *
1003  * Revision 1.3  2000/05/29 21:14:57  gerd
1004  *      Changed the type 'encoding' into a polymorphic variant.
1005  *
1006  * Revision 1.2  2000/05/20 20:31:40  gerd
1007  *      Big change: Added support for various encodings of the
1008  * internal representation.
1009  *
1010  * Revision 1.1  2000/03/13 23:41:44  gerd
1011  *      Initial revision; this code was formerly part of Markup_entity.
1012  *
1013  *
1014  *)