~ubuntu-branches/ubuntu/hardy/pxp/hardy

« back to all changes in this revision

Viewing changes to src/pxp-engine/pxp_entity.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2005-03-29 11:06:39 UTC
  • mfrom: (2.1.2 hoary)
  • Revision ID: james.westby@ubuntu.com-20050329110639-5p39hz1d4aq3r2ec
Tags: 1.1.95-6
* Rebuilt against ocaml 3.08.3
* No longer built with wlex support (since wlex is no longer supported
  upstream and corresponding package has been removed from the debian
  archive)

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
(* $Id: pxp_entity.ml,v 1.16 2002/03/10 23:39:45 gerd Exp $
 
1
(* $Id: pxp_entity.ml 707 2004-09-04 17:25:35Z gerd $
2
2
 * ----------------------------------------------------------------------
3
3
 * PXP: The polymorphic XML parser for Objective Caml.
4
4
 * Copyright by Gerd Stolpmann. See LICENSE for details.
5
5
 *)
6
6
 
7
7
 
8
 
open Pxp_types
 
8
open Pxp_core_types
9
9
open Pxp_lexer_types
10
10
open Pxp_aux
11
11
open Pxp_reader
72
72
type 'entity entity_variables = 
73
73
    { mutable dtd : 'entity preliminary_dtd;
74
74
      mutable name : string;
 
75
      mutable swarner : symbolic_warnings option;
75
76
      mutable warner : collect_warnings;
76
77
      
77
78
      mutable encoding : rep_encoding;
78
 
      mutable lexerset : lexer_set;
 
79
      mutable lfactory : lexer_factory;
79
80
 
80
 
      mutable lexerset_scan_document : Lexing.lexbuf -> (token * lexers);
81
 
      mutable lexerset_scan_document_type : Lexing.lexbuf -> (token * lexers);
82
 
      mutable lexerset_scan_content : Lexing.lexbuf -> (token * lexers);
83
 
      mutable lexerset_scan_within_tag : Lexing.lexbuf -> (token * lexers);
84
 
      mutable lexerset_scan_declaration : Lexing.lexbuf -> (token * lexers);
85
 
      mutable lexerset_scan_decl_comment : Lexing.lexbuf -> (token * lexers);
86
 
      mutable lexerset_scan_content_comment : Lexing.lexbuf -> (token * lexers);
87
 
      mutable lexerset_scan_document_comment : Lexing.lexbuf -> (token * lexers);
88
 
      mutable lexbuf : Lexing.lexbuf;
 
81
      mutable l_scan_document : unit -> (token * lexers);
 
82
      mutable l_scan_document_type : unit -> (token * lexers);
 
83
      mutable l_scan_content : unit -> (token * lexers);
 
84
      mutable l_scan_within_tag : unit -> (token * lexers);
 
85
      mutable l_scan_declaration : unit -> (token * lexers);
 
86
      mutable l_scan_comment : unit -> lexers -> (token * lexers);
 
87
      mutable l_scan_tag_eb : unit -> (token * lexers);
 
88
      mutable l_scan_tag_eb_att : unit -> bool -> (token * lexers);
 
89
      mutable lexobj : lexer_obj;
89
90
        (* The lexical buffer currently used as character source. *)
90
91
 
 
92
      (* Caution: whenever lexobj is changed, the l_* functions must be
 
93
       * updated, too (update_lexobj)
 
94
       *)
 
95
 
91
96
      mutable prolog : prolog_token list option;
92
97
        (* Stores the initial <?xml ...?> token as PI_xml *)
93
98
      mutable prolog_pairs : (string * string) list;
112
117
      mutable normalize_newline : bool;
113
118
        (* Whether this entity converts CRLF or CR to LF, or not *)
114
119
 
 
120
      mutable generate_attribute_events : bool;
 
121
        (* Whether attribute events are generated or not *)
 
122
 
115
123
      mutable line : int;          (* current line *)
116
124
      mutable column : int;        (* current column *)
117
125
 
136
144
;;
137
145
 
138
146
 
139
 
let make_variables the_dtd the_name the_warner init_encoding =
140
 
  let ls = Pxp_lexers.get_lexer_set init_encoding in
 
147
let make_variables the_dtd the_name the_swarner the_warner init_encoding =
 
148
  let lf = Pxp_lexers.get_lexer_factory init_encoding in
 
149
  let lobj = lf # open_string "" in
141
150
  { dtd = (the_dtd : 'entity #preliminary_dtd :> 'entity preliminary_dtd);
142
151
    name = the_name;
143
152
    warner = the_warner;
 
153
    swarner = the_swarner;
144
154
    
145
155
    encoding = init_encoding;
146
 
    lexerset = ls;
 
156
    lfactory = lf;
147
157
 
148
 
    lexerset_scan_document         = ls.scan_document;
149
 
    lexerset_scan_document_type    = ls.scan_document_type;
150
 
    lexerset_scan_content          = ls.scan_content;
151
 
    lexerset_scan_within_tag       = ls.scan_within_tag;
152
 
    lexerset_scan_declaration      = ls.scan_declaration;
153
 
    lexerset_scan_decl_comment     = ls.scan_decl_comment;
154
 
    lexerset_scan_content_comment  = ls.scan_content_comment;
155
 
    lexerset_scan_document_comment = ls.scan_document_comment;
 
158
    l_scan_document         = lobj#scan_document;
 
159
    l_scan_document_type    = lobj#scan_document_type;
 
160
    l_scan_content          = lobj#scan_content;
 
161
    l_scan_within_tag       = lobj#scan_within_tag;
 
162
    l_scan_declaration      = lobj#scan_declaration;
 
163
    l_scan_comment          = lobj#scan_comment;
 
164
    l_scan_tag_eb           = lobj#scan_tag_eb;
 
165
    l_scan_tag_eb_att       = lobj#scan_tag_eb_att;
156
166
    
157
 
    lexbuf = Pxp_lexing.from_string "";
 
167
    lexobj = lobj;
158
168
    
159
169
    prolog = None;
160
170
    prolog_pairs = [];
165
175
    check_text_declaration = true;
166
176
    
167
177
    normalize_newline = true;
168
 
    
 
178
    generate_attribute_events = false;
 
179
 
169
180
    line = 1;
170
181
    column = 0;
171
182
 
183
194
  }
184
195
;;
185
196
 
 
197
let update_lexobj v lobj =
 
198
  v.lexobj <- lobj;
 
199
  v.l_scan_document         <- lobj#scan_document;
 
200
  v.l_scan_document_type    <- lobj#scan_document_type;
 
201
  v.l_scan_content          <- lobj#scan_content;
 
202
  v.l_scan_within_tag       <- lobj#scan_within_tag;
 
203
  v.l_scan_declaration      <- lobj#scan_declaration;
 
204
  v.l_scan_comment          <- lobj#scan_comment;
 
205
  v.l_scan_tag_eb           <- lobj#scan_tag_eb;
 
206
  v.l_scan_tag_eb_att       <- lobj#scan_tag_eb_att;
 
207
;;
 
208
 
 
209
 
186
210
let update_lines v =
187
211
  let n_lines = v.linecount.lines in
188
212
  let n_columns = v.linecount.columns in
195
219
      LineEnd _ -> 
196
220
        v.line <- v.line + 1;
197
221
        v.column <- 0;
198
 
    | (PI(_,_)|PI_xml _|Cdata _) ->
199
 
        count_lines v.linecount (Lexing.lexeme v.lexbuf);
 
222
    | (PI(_,_,_)|PI_xml _|Cdata _) ->
 
223
        count_lines v.linecount v.lexobj#lexeme;
200
224
        update_lines v;
201
225
    | _ -> 
202
 
        v.column <- v.column + Lexing.lexeme_end v.lexbuf 
203
 
                             - Lexing.lexeme_start v.lexbuf
 
226
        v.column <- v.column + v.lexobj#lexeme_strlen
204
227
;;
205
228
 
206
229
let update_lines_within_tag v tok =
218
241
        v.line <- v.line + 1;
219
242
        v.column <- 0;
220
243
    | _ -> 
221
 
        v.column <- v.column + Lexing.lexeme_end v.lexbuf 
222
 
                             - Lexing.lexeme_start v.lexbuf
 
244
        v.column <- v.column + v.lexobj#lexeme_strlen
223
245
;;
224
246
 
225
247
let update_other_lines v tok =
226
 
  count_lines v.linecount (Lexing.lexeme v.lexbuf);
 
248
  count_lines v.linecount v.lexobj#lexeme;
227
249
  update_lines v;
228
250
;;
229
251
 
230
252
 
231
 
class virtual entity the_dtd the_name the_warner init_encoding =
 
253
class virtual entity the_dtd the_name the_swarner the_warner init_encoding =
232
254
  object (self)
233
255
    (* This class prescribes the type of all entity objects. Furthermore,
234
256
     * the default 'next_token' mechanism is implemented.
235
257
     *)
236
258
 
237
 
    val v = make_variables the_dtd the_name the_warner init_encoding
 
259
    val v = make_variables 
 
260
              the_dtd the_name the_swarner the_warner init_encoding
238
261
 
239
262
    method is_ndata = false
240
263
      (* Returns if this entity is an NDATA (unparsed) entity *)
241
264
 
242
265
    method name = v.name
243
266
 
 
267
    method lex_id = v.lex_id
 
268
 
244
269
    method set_lex_id id = v.lex_id <- id
245
270
 
246
271
    method line = v.p_line
247
272
    method column = v.p_column
248
273
 
 
274
    method set_line_column l c =
 
275
      v.line <- l;
 
276
      v.column <- c
 
277
 
249
278
    method encoding = v.encoding
250
279
    (* method lexerset = lexerset *)
251
280
 
257
286
            None -> assert false
258
287
          | Some m -> m
259
288
      : < current_entity : entity; 
260
 
          pop_entity : unit;
 
289
          pop_entity : unit -> unit;
261
290
          push_entity : entity -> unit >
262
291
      )
263
292
 
268
297
    method set_counts_as_external =
269
298
      v.counts_as_external <- true
270
299
 
271
 
 
272
 
    method virtual open_entity : bool -> lexers -> unit
 
300
    method lexer_obj = v.lexobj
 
301
 
 
302
    method virtual resolver : resolver option
 
303
 
 
304
    method virtual open_entity : 
 
305
        ?gen_att_events:bool -> bool -> lexers -> unit
273
306
        (* open_entity force_parsing lexid:
274
307
         * opens the entity, and the first token is scanned by the lexer
275
308
         * 'lexid'. 'force_parsing' forces that Begin_entity and End_entity
298
331
         * from non-document entities do not add these tokens.
299
332
         *)
300
333
 
301
 
    method virtual close_entity : lexers
 
334
    method close_entity =
302
335
        (* close_entity:
303
336
         * closes the entity and returns the name of the lexer that must
304
337
         * be used to scan the next token.
305
338
         *)
 
339
      let current_lex_id = v.lex_id in
 
340
      v.deferred_token <- None;
 
341
      v.lex_id <- Closed;
 
342
      current_lex_id
 
343
 
 
344
    method virtual is_open : bool
 
345
      (* Whether the entity is currently open *)
 
346
 
306
347
 
307
348
    method virtual replacement_text : (string * bool)
308
349
        (* replacement_text:
313
354
         *)
314
355
 
315
356
 
316
 
    method lexbuf = v.lexbuf
 
357
    method lexer_obj = v.lexobj
317
358
 
318
359
 
319
360
    method xml_declaration =
361
402
             * name lex_id' of the next lexer to be used.
362
403
             *)
363
404
            let update_fn = ref update_content_lines in
364
 
            let scan_fn =
 
405
            let tok, lex_id' =
365
406
              match v.lex_id with
366
407
                  Document         -> update_fn := update_other_lines;
367
 
                                      v.lexerset_scan_document
 
408
                                      v.l_scan_document () 
368
409
                | Document_type    -> update_fn := update_other_lines;
369
 
                                      v.lexerset_scan_document_type
370
 
                | Content          -> v.lexerset_scan_content
 
410
                                      v.l_scan_document_type ()
 
411
                | Content          -> v.l_scan_content ()
371
412
                | Within_tag       -> update_fn := update_lines_within_tag;
372
 
                                      v.lexerset_scan_within_tag
 
413
                                      v.l_scan_within_tag ()
 
414
                | Within_tag_entry -> if v.generate_attribute_events then (
 
415
                                        (* like Tag_eb: *)
 
416
                                        update_fn := update_lines_within_tag;
 
417
                                        v.l_scan_tag_eb ()
 
418
                                      ) else (
 
419
                                        (* like Within_tag: *)
 
420
                                        update_fn := update_lines_within_tag;
 
421
                                        v.l_scan_within_tag ()
 
422
                                      )
373
423
                | Declaration      -> update_fn := update_other_lines;
374
 
                                      v.lexerset_scan_declaration
375
 
                | Content_comment  -> update_fn := update_other_lines;
376
 
                                      v.lexerset_scan_content_comment
377
 
                | Decl_comment     -> update_fn := update_other_lines;
378
 
                                      v.lexerset_scan_decl_comment
379
 
                | Document_comment -> update_fn := update_other_lines;
380
 
                                      v.lexerset_scan_document_comment
 
424
                                      v.l_scan_declaration ()
 
425
                | Comment flw_id   -> update_fn := update_other_lines;
 
426
                                      v.l_scan_comment () flw_id
 
427
                | Tag_eb           -> update_fn := update_lines_within_tag;
 
428
                                      v.l_scan_tag_eb ()
 
429
                | Tag_eb_att b     -> (* keep update_content_lines! *)
 
430
                                      v.l_scan_tag_eb_att () b
381
431
                | Ignored_section  -> assert false
382
 
                  (* Ignored_section: only used by method next_ignored_token *)
 
432
                                   (* only used by method next_ignored_token *)
 
433
                | Closed           -> (Eof, Closed)
383
434
            in
384
 
            let tok, lex_id' = scan_fn v.lexbuf in
385
435
 
 
436
            if debug then (
 
437
              prerr_endline ("- Entity " ^ v.name ^ ": " ^ string_of_tok tok);
 
438
              prerr_endline ("         Transition: " ^ 
 
439
                             string_of_lexers v.lex_id ^ " -> " ^ 
 
440
                             string_of_lexers lex_id')
 
441
            );
 
442
            
386
443
            (* Find out the number of lines and characters of the last line: *)
387
444
            !update_fn v tok;
388
445
            v.lex_id <- lex_id';
389
446
 
390
 
            if debug then
391
 
              prerr_endline ("- Entity " ^ v.name ^ ": " ^ string_of_tok tok);
392
 
            
393
447
            (* Throw Ignore and Comment away; Interpret entity references: *)
394
448
            (* NOTE: Of course, references to general entities are not allowed
395
449
             * everywhere; parameter references, too. This is already done by the
410
464
                           ("Reference to entity `" ^ n ^ 
411
465
                            "' violates standalone declaration"));
412
466
                    en # set_debugging_mode debug;
413
 
                    en # open_entity true v.lex_id;
 
467
                    en # open_entity 
 
468
                      ?gen_att_events:(Some v.generate_attribute_events) 
 
469
                      true v.lex_id;
414
470
                    self # manager # push_entity en;
415
471
                    en # next_token;
416
472
                | PERef n   -> 
417
473
                    let en = v.dtd # par_entity n in
418
474
                    en # set_debugging_mode debug;
419
 
                    en # open_entity v.force_parameter_entity_parsing v.lex_id;
 
475
                    en # open_entity 
 
476
                      ?gen_att_events:(Some v.generate_attribute_events)
 
477
                      v.force_parameter_entity_parsing v.lex_id;
420
478
                    self # manager # push_entity en;
421
479
                    en # next_token;
422
480
 
427
485
                    else
428
486
                      CharData s
429
487
 
 
488
          (* Convert LineEnd_att to CharData *)
 
489
                | LineEnd_att s -> 
 
490
                    if v.normalize_newline then 
 
491
                      CharData " "
 
492
                    else
 
493
                      CharData s
 
494
 
430
495
          (* Also normalize CDATA sections *)
431
496
                | Cdata value as cd ->
432
497
                    if v.normalize_newline then 
433
 
                      Cdata(normalize_line_separators v.lexerset value)
 
498
                      Cdata(normalize_line_separators v.lfactory value)
434
499
                    else
435
500
                      cd
436
501
 
437
502
          (* If there are CRLF sequences in a PI value, normalize them, too *)
438
 
                | PI(name,value) as pi ->
 
503
                | PI(name,value,_) as pi ->
439
504
                    if v.normalize_newline then
440
 
                      PI(name, normalize_line_separators v.lexerset value)
 
505
                      PI(name, 
 
506
                         normalize_line_separators v.lfactory value,
 
507
                         (self :> entity_id))
441
508
                    else
442
 
                      pi
 
509
                      PI(name, value, (self :> entity_id))
443
510
         
444
511
          (* Attribute values: If they are already normalized, they are turned
445
512
           * into Attval_nl_normalized. This is detected by other code.
453
520
          (* Another CRLF normalization case: Unparsed_string *)
454
521
                | Unparsed_string value as ustr ->
455
522
                    if v.normalize_newline then
456
 
                      Unparsed_string(normalize_line_separators v.lexerset value)
 
523
                      Unparsed_string(normalize_line_separators v.lfactory value)
457
524
                    else
458
525
                      ustr
459
526
 
536
603
    method private handle_eof =
537
604
      let mng = self # manager in
538
605
      begin try
539
 
        mng # pop_entity;
 
606
        mng # pop_entity();
540
607
        let next_lex_id = self # close_entity in
541
608
        let en = mng # current_entity in
542
609
        en # set_lex_id next_lex_id;
553
620
 
554
621
      (* TODO: Do we need a test on deferred tokens here? *)
555
622
 
556
 
        let tok, lex_id' = v.lexerset.scan_ignored_section v.lexbuf in
557
 
        if v.debug then
558
 
          prerr_endline ("- Entity " ^ v.name ^ ": " ^ string_of_tok tok ^ " (Ignored)");
559
 
        update_other_lines v tok;
560
 
        match tok with
561
 
          | Conditional_begin _ -> Conditional_begin (self :> entity_id)
562
 
          | Conditional_end _   -> Conditional_end   (self :> entity_id)
563
 
          | _                   -> tok
 
623
        if v.lex_id = Closed then
 
624
          Eof
 
625
        else
 
626
          let tok, lex_id' = v.lexobj#scan_ignored_section() in
 
627
          if v.debug then
 
628
            prerr_endline ("- Entity " ^ v.name ^ ": " ^ string_of_tok tok ^ " (Ignored)");
 
629
          update_other_lines v tok;
 
630
          match tok with
 
631
            | Conditional_begin _ -> Conditional_begin (self :> entity_id)
 
632
            | Conditional_end _   -> Conditional_end   (self :> entity_id)
 
633
            | _                   -> tok
564
634
 
565
635
 
566
636
    method process_xmldecl pl =
598
668
      (raise Not_found : ext_id)
599
669
 
600
670
 
 
671
    method resolver_id =
 
672
      (* Returns the resolver ID for external entities. Raises Not_found
 
673
       * for other types of entities.
 
674
       *)
 
675
      (raise Not_found : resolver_id)
 
676
 
 
677
 
601
678
    (* Methods for NDATA entities only: *)
602
679
    method notation = (assert false : string)
603
680
 
619
696
    method name = (name : string)
620
697
    method ext_id = (ext_id : ext_id)
621
698
    method notation = (notation : string)
 
699
    method resolver_id = (raise Not_found : resolver_id)
622
700
 
623
701
    method is_ndata = true
624
702
 
635
713
 
636
714
 
637
715
    method set_manager (m : < current_entity : entity; 
638
 
                              pop_entity : unit;
 
716
                              pop_entity : unit -> unit;
639
717
                              push_entity : entity -> unit >) = 
640
718
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
641
719
          : unit )
642
720
 
 
721
    method resolver = (None : resolver option)
 
722
 
 
723
    method lex_id =
 
724
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
 
725
          : lexers)
 
726
 
643
727
    method set_lex_id (id : lexers) =
644
728
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
645
729
          : unit )
652
736
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
653
737
          : int )
654
738
 
 
739
    method set_line_column (_:int) (_:int) =
 
740
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
 
741
          : unit )
 
742
 
655
743
    method full_name =
656
744
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
657
745
          : string )
663
751
 
664
752
    method set_debugging_mode (_:bool) = ()
665
753
 
666
 
    method open_entity (_:bool) (_:lexers) =
 
754
    method lexer_obj =
 
755
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
 
756
          : lexer_obj )
 
757
 
 
758
    method open_entity ?(gen_att_events:bool option) (_:bool) (_:lexers) =
667
759
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
668
760
          : unit )
669
761
 
671
763
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
672
764
          : lexers )
673
765
 
 
766
    method is_open = false  (* NDATA entities cannot be opened *)
 
767
 
674
768
    method replacement_text =
675
769
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
676
770
          : (string * bool) )
677
771
 
678
 
    method lexbuf =
 
772
    method lexer_obj =
679
773
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
680
 
          : Lexing.lexbuf )
 
774
          : lexer_obj )
681
775
 
682
776
    method next_token =
683
777
      ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
698
792
  end
699
793
;;
700
794
 
701
 
class external_entity the_resolver the_dtd the_name the_warner the_ext_id
 
795
class external_entity the_resolver the_dtd the_name the_swarner the_warner 
 
796
                      the_ext_id
 
797
                      the_system_base
702
798
                      the_p_special_empty_entities
703
799
                      init_encoding
704
800
  =
705
801
  object (self)
706
802
    inherit entity
707
 
              the_dtd the_name the_warner 
 
803
              the_dtd the_name the_swarner the_warner 
708
804
              init_encoding
709
805
            as super
710
806
 
721
817
     *)
722
818
 
723
819
    val resolver = (the_resolver : resolver)
724
 
    val ext_id = (the_ext_id : ext_id)
 
820
    val ext_id = 
 
821
      match (the_ext_id : ext_id) with
 
822
          Public(pubid,sysid) ->
 
823
            (* normalize pubid: *)
 
824
            Public(Pxp_aux.normalize_public_id pubid,sysid)
 
825
        | other ->
 
826
            other
 
827
 
 
828
    val system_base = (the_system_base : string option)
725
829
 
726
830
    val p_special_empty_entities = (the_p_special_empty_entities : bool)
727
831
 
751
855
 
752
856
    method ext_id = ext_id
753
857
 
754
 
    method open_entity force_parsing init_lex_id =
 
858
    method resolver = Some resolver
 
859
 
 
860
    method resolver_id = 
 
861
      let rid = resolver_id_of_ext_id ext_id in
 
862
      { rid with rid_system_base = system_base }
 
863
 
 
864
    method open_entity ?(gen_att_events=false) force_parsing init_lex_id =
755
865
      (* Note that external entities are always parsed, i.e. Begin_entity
756
866
       * and End_entity tokens embrace the inner tokens to force that
757
867
       * the entity is only called where the syntax allows it.
758
868
       *)
759
869
      if resolver_is_open then
760
870
        raise(Validation_error("Recursive reference to entity `" ^ v.name ^ "'"));
761
 
      let lex = 
 
871
      let lex_src = 
762
872
        try
763
 
          resolver # open_in ext_id 
 
873
          resolver # open_rid (self # resolver_id)
764
874
        with
765
875
            Pxp_reader.Not_competent ->
766
876
              raise(Error ("No input method available for this external entity: " ^ 
773
883
                           self # full_name ^ "; reason: " ^ 
774
884
                           string_of_exn e))
775
885
      in
 
886
 
 
887
      let lexobj = v.lfactory#open_source lex_src in
 
888
      update_lexobj v lexobj;
776
889
      resolver_is_open <- true;
777
 
      v.lexbuf  <- lex;
778
890
      v.prolog  <- None;
779
891
      v.lex_id  <- init_lex_id;
780
892
      state <- At_beginning;
782
894
      v.column <- 0;
783
895
      v.at_bof <- true;
784
896
      v.normalize_newline <- true;
 
897
      v.generate_attribute_events <- gen_att_events;
785
898
 
786
899
 
787
900
    method private handle_bof tok =
824
937
        failwith ("External entity " ^ v.name ^ " not open");
825
938
      resolver # close_in;
826
939
      resolver_is_open <- false;
827
 
      v.lex_id
 
940
      super # close_entity
 
941
 
 
942
 
 
943
    method is_open = resolver_is_open
828
944
 
829
945
 
830
946
    method replacement_text =
836
952
       *)
837
953
      if resolver_is_open then
838
954
        raise(Validation_error("Recursive reference to entity `" ^ v.name ^ "'"));
839
 
      let lex = 
 
955
      let lex_src = 
840
956
        try
841
 
          resolver # open_in ext_id 
 
957
          resolver # open_rid (self # resolver_id)
842
958
        with
843
959
            Pxp_reader.Not_competent ->
844
960
              raise(Error ("No input method available for this external entity: " ^ 
851
967
                           self # full_name ^ "; reason: " ^ 
852
968
                           string_of_exn e))
853
969
      in
 
970
 
 
971
      let lexobj = v.lfactory#open_source lex_src in
 
972
      update_lexobj v lexobj;
854
973
      resolver_is_open <- true;
855
 
      v.lexbuf  <- lex;
856
974
      v.prolog  <- None;
857
975
      (* arbitrary:    lex_id  <- init_lex_id; *)
858
976
      state <- At_beginning;
860
978
      v.column <- 0;
861
979
      v.at_bof <- true;
862
980
      (* First check if the first token of 'lex' is <?xml...?> *)
863
 
      begin match v.lexerset.scan_only_xml_decl lex with
864
 
          PI_xml pl ->
865
 
            self # process_xmldecl pl
866
 
        | Eof ->
867
 
            (* This only means that the first token was not <?xml...?>;
868
 
             * the "Eof" token represents the empty string.
869
 
             *)
870
 
            self # process_missing_xmldecl
871
 
        | _ ->
872
 
            (* Must not happen. *)
873
 
            assert false
874
 
      end;
 
981
      if lexobj#detect_xml_pi() then begin
 
982
        (* detect_xml_pi scans "<?xml" ws+. Read the rest of the XML
 
983
         * declaration.
 
984
         *)
 
985
        match lexobj#scan_pi_string() with
 
986
            Some pi ->
 
987
              begin match
 
988
                Pxp_lex_aux.scan_pi ("xml " ^ pi) v.lfactory
 
989
              with
 
990
                  PI_xml pl ->
 
991
                    self # process_xmldecl pl
 
992
                | _ ->
 
993
                    assert false   (* cannot happen *)
 
994
              end
 
995
          | None ->
 
996
              raise(WF_error("Bad XML declaration"))
 
997
      end
 
998
      else
 
999
        (* This only means that the first token was not <?xml...?>;
 
1000
         * the "Eof" token represents the empty string.
 
1001
         *)
 
1002
        self # process_missing_xmldecl;
875
1003
      (* Then create the replacement text. *)
876
1004
      let rec scan_and_expand () =
877
 
        match v.lexerset.scan_dtd_string v.lexbuf with
 
1005
        match lexobj#scan_dtd_string() with
878
1006
            ERef n -> "&" ^ n ^ ";" ^ scan_and_expand()
879
1007
          | CRef(-1) -> "\n" ^ scan_and_expand()
880
1008
          | CRef(-2) -> "\n" ^ scan_and_expand()
881
1009
          | CRef(-3) -> "\n" ^ scan_and_expand()
882
 
          | CRef k -> character v.encoding v.warner k ^ scan_and_expand()
 
1010
          | CRef k -> 
 
1011
              character 
 
1012
                ?swarner:v.swarner v.encoding v.warner k ^ scan_and_expand()
883
1013
          | CharData x -> x ^ scan_and_expand()
884
1014
          | PERef n ->
885
1015
              let en = v.dtd # par_entity n in
901
1031
;;
902
1032
 
903
1033
 
904
 
class document_entity  the_resolver the_dtd the_name the_warner the_ext_id
 
1034
class document_entity  the_resolver the_dtd the_name the_swarner the_warner
 
1035
                       the_ext_id
 
1036
                       the_system_base
905
1037
                       init_encoding
906
1038
  =
907
1039
  object (self)
908
 
    inherit external_entity  the_resolver the_dtd the_name the_warner
909
 
                             the_ext_id false 
 
1040
    inherit external_entity  the_resolver the_dtd the_name the_swarner 
 
1041
                             the_warner
 
1042
                             the_ext_id the_system_base false 
910
1043
                             init_encoding
911
1044
 
912
1045
    (* A document entity is an external entity that does not allow
924
1057
;;
925
1058
 
926
1059
 
927
 
class internal_entity the_dtd the_name the_warner the_literal_value
 
1060
class internal_entity the_dtd the_name the_swarner the_warner the_literal_value
928
1061
                      the_p_internal_subset 
929
1062
                      init_is_parameter_entity
930
1063
                      init_encoding
941
1074
 
942
1075
  object (self)
943
1076
    inherit entity
944
 
              the_dtd the_name the_warner 
 
1077
              the_dtd the_name the_swarner the_warner 
945
1078
              init_encoding
946
1079
            as super
947
1080
 
956
1089
 
957
1090
 
958
1091
    initializer
959
 
    let lexbuf = Pxp_lexing.from_string the_literal_value in
 
1092
    let lexobj = v.lfactory#open_string the_literal_value in
960
1093
    let rec scan_and_expand () =
961
 
      match v.lexerset.scan_dtd_string lexbuf with
 
1094
      match lexobj#scan_dtd_string() with
962
1095
          ERef n -> "&" ^ n ^ ";" ^ scan_and_expand()
963
1096
        | CRef(-1) -> "\r\n" ^ scan_and_expand()
964
1097
        | CRef(-2) -> "\r" ^ scan_and_expand()
965
1098
        | CRef(-3) -> "\n" ^ scan_and_expand()
966
 
        | CRef k -> character v.encoding v.warner k ^ scan_and_expand()
 
1099
        | CRef k -> 
 
1100
            character 
 
1101
              ?swarner:v.swarner v.encoding v.warner k ^ scan_and_expand()
967
1102
        | CharData x -> x ^ scan_and_expand()
968
1103
        | PERef n ->
969
1104
            if p_internal_subset then
998
1133
      assert(e = "");
999
1134
 
1000
1135
 
1001
 
    method open_entity force_parsing init_lex_id =
 
1136
    method open_entity ?(gen_att_events = false) force_parsing init_lex_id =
1002
1137
      if is_open then
1003
1138
        raise(Validation_error("Recursive reference to entity `" ^ v.name ^ "'"));
1004
1139
 
1005
1140
      p_parsed_actually <- force_parsing;
1006
 
      v.lexbuf  <- Pxp_lexing.from_string 
 
1141
      let lexobj = v.lfactory#open_string
1007
1142
                     (if is_parameter_entity then
1008
1143
                        (" " ^ replacement_text ^ " ")
1009
1144
                      else
1010
 
                        replacement_text);
 
1145
                        replacement_text) in
 
1146
      update_lexobj v lexobj;
1011
1147
      v.prolog  <- None;
1012
1148
      v.lex_id  <- init_lex_id;
1013
1149
      state <- At_beginning;
1015
1151
      v.line <- 1;
1016
1152
      v.column <- 0;
1017
1153
      v.at_bof <- true;       (* CHECK: Is this right? *)
 
1154
      v.generate_attribute_events <- gen_att_events;
1018
1155
 
1019
1156
 
1020
1157
    method private handle_bof tok =
1062
1199
      if not is_open then
1063
1200
        failwith ("Internal entity " ^ v.name ^ " not open");
1064
1201
      is_open <- false;
1065
 
      v.lex_id
 
1202
      super # close_entity
 
1203
 
 
1204
 
 
1205
    method is_open = is_open
1066
1206
 
1067
1207
 
1068
1208
    method replacement_text =
1069
1209
      if is_open then
1070
1210
        raise(Validation_error("Recursive reference to entity `" ^ v.name ^ "'"));
1071
1211
      replacement_text, contains_external_references
1072
 
  end
1073
 
;;
1074
 
 
1075
 
(**********************************************************************)
1076
 
 
1077
 
(* An 'entity_manager' is a stack of entities, where the topmost entity
1078
 
 * is the currently active entity, the second entity is the entity that
1079
 
 * referred to the active entity, and so on.
1080
 
 *
1081
 
 * The entity_manager can communicate with the currently active entity.
1082
 
 *
1083
 
 * The entity_manager provides an interface for the parser; the functions
1084
 
 * returning the current token and the next token are exported.
1085
 
 *)
1086
 
 
1087
 
class entity_manager (init_entity : entity) =
1088
 
  object (self)
1089
 
    val mutable entity_stack = Stack.create()
1090
 
    val mutable current_entity = init_entity
1091
 
    val mutable current_entity's_full_name = lazy (init_entity # full_name)
1092
 
                                   
1093
 
    val mutable yy_get_next_ref = ref (fun () -> assert false)
1094
 
 
1095
 
    initializer
1096
 
      init_entity # set_manager (self :> 
1097
 
                                 < current_entity : entity; 
1098
 
                                   pop_entity : unit;
1099
 
                                   push_entity : entity -> unit >
1100
 
                                );
1101
 
      yy_get_next_ref := (fun () -> init_entity # next_token)
1102
 
 
1103
 
    method push_entity e =
1104
 
      e # set_manager (self :> 
1105
 
                       < current_entity : entity; 
1106
 
                         pop_entity : unit;
1107
 
                         push_entity : entity -> unit >
1108
 
                      );
1109
 
      Stack.push (current_entity, current_entity's_full_name) entity_stack;
1110
 
      current_entity <- e;
1111
 
      current_entity's_full_name <- lazy (e # full_name);
1112
 
      yy_get_next_ref := (fun () -> e # next_token);
1113
 
 
1114
 
    method pop_entity =
1115
 
      (* May raise Stack.Empty *)
1116
 
      let e, e_name = Stack.pop entity_stack in
1117
 
      current_entity <- e;
1118
 
      current_entity's_full_name <- e_name;
1119
 
      yy_get_next_ref := (fun () -> e # next_token);
1120
 
 
1121
 
 
1122
 
 
1123
 
    method position_string =
1124
 
      (* Gets a string describing the position of the last token;
1125
 
       * includes an entity backtrace
1126
 
       *)
1127
 
      let b = Buffer.create 200 in
1128
 
      Buffer.add_string b
1129
 
        ("In entity " ^ current_entity # full_name
1130
 
         ^ ", at line " ^ string_of_int (current_entity # line)
1131
 
         ^ ", position " ^ string_of_int (current_entity # column)
1132
 
         ^ ":\n");
1133
 
      Stack.iter
1134
 
        (fun (e, e_name) ->
1135
 
           Buffer.add_string b 
1136
 
             ("Called from entity " ^ Lazy.force e_name
1137
 
              ^ ", line " ^ string_of_int (e # line)
1138
 
              ^  ", position " ^ string_of_int (e # column)
1139
 
              ^ ":\n");
1140
 
        )
1141
 
        entity_stack;
1142
 
      Buffer.contents b
1143
 
 
1144
 
 
1145
 
    method position =
1146
 
      (* Returns the triple (full_name, line, column) of the last token *)
1147
 
      Lazy.force current_entity's_full_name, 
1148
 
      current_entity # line,
1149
 
      current_entity # column
1150
 
 
1151
 
 
1152
 
    method current_entity_counts_as_external =
1153
 
      (* Whether the current entity counts as external to the main
1154
 
       * document for the purpose of stand-alone checks.
1155
 
       *)
1156
 
      (* TODO: improve performance *)
1157
 
      let is_external = ref false in
1158
 
      let check (e, _) =
1159
 
        if e # counts_as_external then begin
1160
 
          is_external := true;
1161
 
        end;
1162
 
      in
1163
 
      check (current_entity,());
1164
 
      Stack.iter check entity_stack;
1165
 
      !is_external
1166
 
 
1167
 
 
1168
 
    method current_entity  = current_entity
1169
 
 
1170
 
    method yy_get_next_ref = yy_get_next_ref
1171
 
 
1172
 
  end
1173
 
;;
1174
 
      
1175
 
 
1176
 
(* ======================================================================
1177
 
 * History:
1178
 
 *
1179
 
 * $Log: pxp_entity.ml,v $
1180
 
 * Revision 1.16  2002/03/10 23:39:45  gerd
1181
 
 *      ext_id works also for external entities.
1182
 
 *
1183
 
 * Revision 1.15  2002/02/20 00:25:23  gerd
1184
 
 *      using Pxp_lexing instead of Lexing.
1185
 
 *
1186
 
 * Revision 1.14  2001/06/28 22:42:07  gerd
1187
 
 *      Fixed minor problems:
1188
 
 *      - Comments must be contained in one entity
1189
 
 *      - Pxp_document.document is now initialized with encoding.
1190
 
 *           the DTD encoding may be initialized too late.
1191
 
 *
1192
 
 * Revision 1.13  2001/04/22 14:14:41  gerd
1193
 
 *      Updated to support private IDs.
1194
 
 *
1195
 
 * Revision 1.12  2001/04/22 12:04:55  gerd
1196
 
 *      external_entity, method replacement_text: catches errors
1197
 
 * from pxp_reader and transforms them
1198
 
 *
1199
 
 * Revision 1.11  2000/10/01 19:49:51  gerd
1200
 
 *      Numerous optimizations in the class "entity".
1201
 
 *
1202
 
 * Revision 1.10  2000/09/21 21:28:16  gerd
1203
 
 *      New token IgnoreLineEnd: simplifies line counting, and
1204
 
 * corrects a bug.
1205
 
 *
1206
 
 * Revision 1.9  2000/09/17 00:11:22  gerd
1207
 
 *      Optimized line numbering.
1208
 
 *
1209
 
 * Revision 1.8  2000/09/09 16:39:05  gerd
1210
 
 *      Changed comment.
1211
 
 *
1212
 
 * Revision 1.7  2000/09/05 21:52:31  gerd
1213
 
 *      class internal_entity: Previously, the method open_entity
1214
 
 * intialized the slot last_token to Eof. This is wrong, because
1215
 
 * this causes that handle_bof is never called. The slot last_token
1216
 
 * is now initialized to Bof.
1217
 
 *      Critical negative tests: data_jclark_notwf/not-sa/002,
1218
 
 * data_jclark_notwf/sa/153.xml, data_jclark_notwf/sa/161.xml. The
1219
 
 * error messages of these tests changed (checked; the new messages
1220
 
 * are better).
1221
 
 *
1222
 
 * Revision 1.6  2000/07/14 13:55:00  gerd
1223
 
 *      Cosmetic changes.
1224
 
 *
1225
 
 * Revision 1.5  2000/07/09 17:51:50  gerd
1226
 
 *      Entities return now the beginning of a token as its
1227
 
 * position.
1228
 
 *      New method 'position' for entity_manager.
1229
 
 *
1230
 
 * Revision 1.4  2000/07/09 01:05:04  gerd
1231
 
 *      Exported methods 'ext_id' and 'notation' anyway.
1232
 
 *
1233
 
 * Revision 1.3  2000/07/08 16:28:05  gerd
1234
 
 *      Updated: Exception 'Not_resolvable' is taken into account.
1235
 
 *
1236
 
 * Revision 1.2  2000/07/04 22:12:47  gerd
1237
 
 *      Update: Case ext_id = Anonymous.
1238
 
 *      Update: Handling of the exception Not_competent when reading
1239
 
 * from a resolver.
1240
 
 *
1241
 
 * Revision 1.1  2000/05/29 23:48:38  gerd
1242
 
 *      Changed module names:
1243
 
 *              Markup_aux          into Pxp_aux
1244
 
 *              Markup_codewriter   into Pxp_codewriter
1245
 
 *              Markup_document     into Pxp_document
1246
 
 *              Markup_dtd          into Pxp_dtd
1247
 
 *              Markup_entity       into Pxp_entity
1248
 
 *              Markup_lexer_types  into Pxp_lexer_types
1249
 
 *              Markup_reader       into Pxp_reader
1250
 
 *              Markup_types        into Pxp_types
1251
 
 *              Markup_yacc         into Pxp_yacc
1252
 
 * See directory "compatibility" for (almost) compatible wrappers emulating
1253
 
 * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
1254
 
 *
1255
 
 * ======================================================================
1256
 
 * Old logs from markup_entity.ml:
1257
 
 *
1258
 
 * Revision 1.27  2000/05/29 21:14:57  gerd
1259
 
 *      Changed the type 'encoding' into a polymorphic variant.
1260
 
 *
1261
 
 * Revision 1.26  2000/05/28 17:24:55  gerd
1262
 
 *      Bugfixes.
1263
 
 *
1264
 
 * Revision 1.25  2000/05/27 19:23:32  gerd
1265
 
 *      The entities store whether they count as external with
1266
 
 * respect to the standalone check: New methods counts_as_external
1267
 
 * and set_counts_as_external.
1268
 
 *      The entity manager can find out whether the current
1269
 
 * entity counts as external: method current_entity_counts_as_external.
1270
 
 *
1271
 
 * Revision 1.24  2000/05/20 20:31:40  gerd
1272
 
 *      Big change: Added support for various encodings of the
1273
 
 * internal representation.
1274
 
 *
1275
 
 * Revision 1.23  2000/05/14 21:51:24  gerd
1276
 
 *      Change: Whitespace is handled by the grammar, and no longer
1277
 
 * by the entity.
1278
 
 *
1279
 
 * Revision 1.22  2000/05/14 17:50:54  gerd
1280
 
 *      Updates because of changes in the token type.
1281
 
 *
1282
 
 * Revision 1.21  2000/05/09 00:02:44  gerd
1283
 
 *      Conditional sections are now recognized by the parser.
1284
 
 * There seem some open questions; see the TODO comments!
1285
 
 *
1286
 
 * Revision 1.20  2000/05/08 21:58:22  gerd
1287
 
 *      Introduced entity_manager as communication object between
1288
 
 * the parser and the currently active entity.
1289
 
 *      New hooks handle_bof and handle_eof.
1290
 
 *      Removed "delegated entities". The entity manager contains
1291
 
 * the stack of open entities.
1292
 
 *      Changed the way Begin_entity and End_entity are inserted.
1293
 
 * This is now done by handle_bof and handle_eof.
1294
 
 *      The XML declaration is no longer detected by the entity.
1295
 
 * This is now done by the parser.
1296
 
 *
1297
 
 * Revision 1.19  2000/05/01 15:18:44  gerd
1298
 
 *      Improved CRLF handling in the replacement text of entities.
1299
 
 *      Changed one error message.
1300
 
 *
1301
 
 * Revision 1.18  2000/04/30 18:18:39  gerd
1302
 
 *      Bugfixes: The conversion of CR and CRLF to LF is now hopefully
1303
 
 * done right. The new variable "normalize_newline" indicates whether
1304
 
 * normalization must happen for that type of entity. The normalization
1305
 
 * if actually carried out separately for every token that needs it.
1306
 
 *
1307
 
 * Revision 1.17  2000/03/13 23:42:38  gerd
1308
 
 *      Removed the resolver classes, and put them into their
1309
 
 * own module (Markup_reader).
1310
 
 *
1311
 
 * Revision 1.16  2000/02/22 01:06:58  gerd
1312
 
 *      Bugfix: Resolvers are properly re-initialized. This bug caused
1313
 
 * that entities could not be referenced twice in the same document.
1314
 
 *
1315
 
 * Revision 1.15  2000/01/20 20:54:11  gerd
1316
 
 *      New config.errors_with_line_numbers.
1317
 
 *
1318
 
 * Revision 1.14  2000/01/08 18:59:03  gerd
1319
 
 *      Corrected the string resolver.
1320
 
 *
1321
 
 * Revision 1.13  1999/09/01 22:58:23  gerd
1322
 
 *      Method warn_not_latin1 raises Illegal_character if the character
1323
 
 * does not match the Char production.
1324
 
 *      External entities that are not document entities check if the
1325
 
 * <?xml...?> declaration at the beginning matches the TextDecl production.
1326
 
 *      Method xml_declaration has type ... list option, not ... list.
1327
 
 *      Tag_beg and Tag_end now carry an entity_id with them.
1328
 
 *      The code to check empty entities has changed. That the Begin_entity/
1329
 
 * End_entity pair is not to be added must be explicitly turned on. See the
1330
 
 * description of empty entity handling in design.txt.
1331
 
 *      In internal subsets entity declarations are not allowed to refer
1332
 
 * to parameter entities. The internal_entity class can do this now.
1333
 
 *      The p_parsed parameter of internal_entity has gone. It was simply
1334
 
 * superflous.
1335
 
 *
1336
 
 * Revision 1.12  1999/09/01 16:24:13  gerd
1337
 
 *      The method replacement_text returns the text as described for
1338
 
 * "included in literal". The former behaviour has been dropped to include
1339
 
 * a leading and a trailing space character for parameter entities.
1340
 
 *      Bugfix: When general entities are included, they are always parsed.
1341
 
 *
1342
 
 * Revision 1.11  1999/08/31 19:13:31  gerd
1343
 
 *      Added checks on proper PE nesting. The idea is that tokens such
1344
 
 * as Decl_element and Decl_rangle carry an entity ID with them. This ID
1345
 
 * is simply an object of type < >, i.e. you can only test on identity.
1346
 
 * The lexer always produces tokens with a dummy ID because it does not
1347
 
 * know which entity is the current one. The entity layer replaces the dummy
1348
 
 * ID with the actual ID. The parser checks that the IDs of pairs such as
1349
 
 * Decl_element and Decl_rangle are the same; otherwise a Validation_error
1350
 
 * is produced.
1351
 
 *
1352
 
 * Revision 1.10  1999/08/19 01:06:41  gerd
1353
 
 *      Improved error messages: external entities print their
1354
 
 * ext id, too
1355
 
 *
1356
 
 * Revision 1.9  1999/08/15 20:35:48  gerd
1357
 
 *      Improved error messages.
1358
 
 *      Before the tokens Plus, Star, Qmark space is not allowed any longer.
1359
 
 *      Detection of recursive entity references is a bit cleaner.
1360
 
 *
1361
 
 * Revision 1.8  1999/08/15 15:33:44  gerd
1362
 
 *      Revised whitespace checking: At certain positions there must be
1363
 
 * white space. These checks cannot be part of the lexer, as %entity; counts
1364
 
 * as white space. They cannot be part of the yacc parser because one look-ahead
1365
 
 * token would not suffice if we did that. So these checks must be done by the
1366
 
 * entity layer. Luckily, the rules are simple: There are simply a number of
1367
 
 * token pairs between which white space must occur independently of where
1368
 
 * these token have been found. Two variables, "space_seen", and "last_token"
1369
 
 * have been added in order to check these rules.
1370
 
 *
1371
 
 * Revision 1.7  1999/08/15 00:41:06  gerd
1372
 
 *      The [ token of conditional sections is now allowed to occur
1373
 
 * in a different entity.
1374
 
 *
1375
 
 * Revision 1.6  1999/08/15 00:29:02  gerd
1376
 
 *      The method "attlist_replacement_text" has gone. There is now a
1377
 
 * more general "replacement_text" method that computes the replacement
1378
 
 * text for both internal and external entities. Additionally, this method
1379
 
 * returns whether references to external entities have been resolved;
1380
 
 * this is checked in the cases where formerly "attlist_replacement_text"
1381
 
 * was used as it is not allowed everywhere.
1382
 
 *      Entities have a new slot "need_spaces" that indicates that the
1383
 
 * next token must be white space or a parameter reference. The problem
1384
 
 * was that "<!ATTLIST%e;" is legal because when including parameter
1385
 
 * entities white space is added implicitly. Formerly, the white space
1386
 
 * was expected by the underlying lexer; now the lexer does not check
1387
 
 * anymore that "<!ATTLIST" is followed by white space because the lexer
1388
 
 * cannot handle parameter references. Because of this, the check on
1389
 
 * white space must be done by the entity.
1390
 
 *
1391
 
 * Revision 1.5  1999/08/14 22:57:19  gerd
1392
 
 *      It is allowed that external entities are empty because the
1393
 
 * empty string is well-parsed for both declarations and contents. Empty
1394
 
 * entities can be referenced anywhere because the references are replaced
1395
 
 * by nothing. Because of this, the Begin_entity...End_entity brace is only
1396
 
 * inserted if the entity is non-empty. (Otherwise references to empty
1397
 
 * entities would not be allowed anywhere.)
1398
 
 *      As a consequence, the grammar has been changed such that a
1399
 
 * single Eof is equivalent to Begin_entity,End_entity without content.
1400
 
 *
1401
 
 * Revision 1.4  1999/08/14 22:11:19  gerd
1402
 
 *         Several objects have now a "warner" as argument which is
1403
 
 * an object with a "warn" method. This is used to warn about characters
1404
 
 * that cannot be represented in the Latin 1 alphabet.
1405
 
 *      Previously, the resolvers had features in order to warn about
1406
 
 * such characters; this has been removed.
1407
 
 *      UTF-8 streams can be read even if they contain characters
1408
 
 * that cannot be represented by 16 bits.
1409
 
 *      The buffering used in the resolvers is now solved in a
1410
 
 * cleaner way; the number of characters that are expected to be read
1411
 
 * from a source can be limited. This removes a bug with UTF-16 streams
1412
 
 * that previously lead to wrong exceptions; and the buffering is more
1413
 
 * efficient, too.
1414
 
 *
1415
 
 * Revision 1.3  1999/08/11 14:58:53  gerd
1416
 
 *      Some more names for encodings are allowed, such as "utf8" instead
1417
 
 * of the standard name "UTF-8".
1418
 
 *      'resolve_as_file' interprets relative file names as relative to
1419
 
 * the "parent" resolver.
1420
 
 *
1421
 
 * Revision 1.2  1999/08/10 21:35:07  gerd
1422
 
 *      The XML/encoding declaration at the beginning of entities is
1423
 
 * evaluated. In particular, entities have now a method "xml_declaration"
1424
 
 * which returns the name/value pairs of such a declaration. The "encoding"
1425
 
 * setting is interpreted by the entity itself; "version", and "standalone"
1426
 
 * are interpreted by Markup_yacc.parse_document_entity. Other settings
1427
 
 * are ignored (this does not conform to the standard; the standard prescribes
1428
 
 * that "version" MUST be given in the declaration of document; "standalone"
1429
 
 * and "encoding" CAN be declared; no other settings are allowed).
1430
 
 *      TODO: The user should be warned if the standard is not exactly
1431
 
 * fulfilled. -- The "standalone" property is not checked yet.
1432
 
 *
1433
 
 * Revision 1.1  1999/08/10 00:35:51  gerd
1434
 
 *      Initial revision.
1435
 
 *
1436
 
 *
1437
 
 *)
 
1212
 
 
1213
 
 
1214
    method resolver = (None : resolver option)
 
1215
  end
 
1216
;;
 
1217
 
 
1218
 
 
1219
(* An entity_section is an object that reads a section from an underlying
 
1220
 * entity as if this section was an entity of its own. In detail, the
 
1221
 * following rules apply:
 
1222
 * - If a token is read from the entity_section, it is actually read from
 
1223
 *   the underlying entity (except the first and the last token). I.e.
 
1224
 *   the token stream of the entity_section and the underlying entity is
 
1225
 *   essentially the same.
 
1226
 * - However, the entity_section has its own lexical context. The method
 
1227
 *   set_lex_id changes only the lexer ID of the entity_section, and not
 
1228
 *   of the underlying entity.
 
1229
 * - The first token is always Begin_entity, and the last token is always
 
1230
 *   End_entity. These tokens are not taken from the underlying entity,
 
1231
 *   but simpy pretended at the beginning and at the end of the section.
 
1232
 * - The section begins at the current position of the (open) underlying
 
1233
 *   entity when the method open_entity of the section is called. It is 
 
1234
 *   an error if the underlying entity is at the beginning itself.
 
1235
 *   [TODO: The latter condition is currently not checked.]
 
1236
 * - The section ends when the method close_entity is called. The next
 
1237
 *   token will be End_token, and then an endless sequence of Eof.
 
1238
 * - A section cannot be opened a second time.
 
1239
 * - Changes of encodings are ignored. (The underlying entity must do that.)
 
1240
 *)
 
1241
 
 
1242
type section_state = P_bof | P_normal of int | P_pre_eof | P_eof
 
1243
  (* P_normal n: The number n is the number of open inner entities *)
 
1244
 
 
1245
class entity_section (init_ent:entity) =
 
1246
object (self) 
 
1247
  val ent = init_ent
 
1248
  val mutable state = P_bof
 
1249
  val mutable is_open = false
 
1250
  val mutable saved_lex_id = Closed
 
1251
 
 
1252
  method is_ndata = ent # is_ndata
 
1253
  method name = ent # name
 
1254
  method lex_id = ent # lex_id
 
1255
  method set_lex_id = 
 
1256
    if not is_open then
 
1257
      failwith "Pxp_entity.entity_section#set_lex_id: not open";
 
1258
    ent # set_lex_id
 
1259
  method line = ent # line
 
1260
  method column = ent # column
 
1261
  method set_line_column = 
 
1262
    if not is_open then
 
1263
      failwith "Pxp_entity.entity_section#set_line_column: not open";
 
1264
    ent # set_line_column
 
1265
  method encoding = ent # encoding
 
1266
  method set_manager (_ : < current_entity : entity; 
 
1267
                            pop_entity : unit -> unit;
 
1268
                            push_entity : entity -> unit >) = ()
 
1269
  method counts_as_external = ent # counts_as_external
 
1270
  method set_counts_as_external : unit = 
 
1271
    failwith "Pxp_entity.entity_section#set_counts_as_external: not possible";
 
1272
  method lexer_obj = ent # lexer_obj
 
1273
  method resolver = ent # resolver
 
1274
  method resolver_id = ent # resolver_id
 
1275
  method open_entity ?(gen_att_events:bool option) (_:bool) (lid:lexers) = 
 
1276
    if is_open then
 
1277
      failwith "Pxp_entity.entity_section#open_entity: already open";
 
1278
    if not ent#is_open then
 
1279
      failwith "Pxp_entity.entity_section#open_entity: Underlying entity is not open";
 
1280
    saved_lex_id <- ent # lex_id;
 
1281
    state <- P_bof;
 
1282
    is_open <- true;
 
1283
    ent # set_lex_id lid;
 
1284
  method close_entity =
 
1285
    if not is_open then
 
1286
      failwith "Pxp_entity.entity_section#close_entity: not open";
 
1287
    is_open <- false;
 
1288
    ent # set_lex_id saved_lex_id;
 
1289
    assert (match state with P_bof | P_normal _ -> true | _ -> false);
 
1290
    (* CHECK: P_normal n when n>0 *)
 
1291
    state <- P_pre_eof;
 
1292
    saved_lex_id
 
1293
  method is_open = is_open
 
1294
  method replacement_text : (string * bool) =
 
1295
    failwith "Pxp_entity.entity_section#replacement_text: not possible"
 
1296
  method xml_declaration = ent # xml_declaration
 
1297
  method set_debugging_mode = ent # set_debugging_mode
 
1298
  method full_name = ent # full_name
 
1299
  method next_token =
 
1300
    match state with
 
1301
      | P_bof ->
 
1302
          state <- P_normal 0;
 
1303
          Begin_entity
 
1304
      | P_normal n -> 
 
1305
          let tok = ent # next_token in
 
1306
          (* Notes:
 
1307
           * - [tok = Begin_entity] can have two reasons: [ent] has produced
 
1308
           *   [Begin_entity], or [ent] has just found an entity reference
 
1309
           *   whose entity has been opened. Because the latter is possible
 
1310
           *   we do not catch [Begin_entity] here.
 
1311
           * - [tok = End_entity]: This token is always produced by [ent],
 
1312
           *   and so we can signal an error 
 
1313
           *)
 
1314
          ( match tok with
 
1315
              | (End_entity | Eof) ->
 
1316
                  raise(Error "Cannot end entity here")
 
1317
              | _ ->
 
1318
                  tok
 
1319
          )
 
1320
      | P_pre_eof -> 
 
1321
          state <- P_eof; 
 
1322
          End_entity
 
1323
      | P_eof -> 
 
1324
          Eof
 
1325
  method next_ignored_token =
 
1326
    (* We can ignore End_entity and Eof because the caller already signals
 
1327
     * an error when the entity ends in an IGNORE section
 
1328
     *)
 
1329
    ent # next_ignored_token
 
1330
  method process_xmldecl (_:prolog_token list) = ()
 
1331
  method process_missing_xmldecl = ()
 
1332
  method ext_id = ent # ext_id
 
1333
  method notation = ent # notation
 
1334
end
 
1335
;;
 
1336
 
 
1337
(* class entity_manager: has been moved to Pxp_entity_manager *)
 
1338