# 12 "cut.mll"
open Lexing
open Stack
let header = "$Id: cut.mll,v 1.52 2006-10-16 12:39:00 maranget Exp $"
let verbose = ref 0
let name = ref "main"
and count = ref 0
;;
let language = ref "eng"
let base = ref None
let changed_t = Hashtbl.create 17
let record_changed oldname newname =
try
let _ = Hashtbl.find changed_t oldname in
Hashtbl.replace changed_t oldname newname
with Not_found ->
Hashtbl.add changed_t oldname newname
let rec check_changed name =
try Hashtbl.find changed_t name
with Not_found -> name
let real_name name =
let name = check_changed name in
match !base with
| None -> name
| Some dir -> Filename.concat dir name
let real_open_out name = open_out (real_name name)
type toc_style = Normal | Both | Special
let toc_style = ref Normal
let cross_links = ref true
and some_links = ref false
let env = Hashtbl.create 17
let imgsrc img alt =
Printf.sprintf "" img alt
let _ =
Hashtbl.add env "UPTXT" (imgsrc "contents_motif.gif" "Up") ;
Hashtbl.add env "PREVTXT" (imgsrc "previous_motif.gif" "Previous") ;
Hashtbl.add env "NEXTTXT" (imgsrc "next_motif.gif" "Next") ;
()
let get_env key =
try Hashtbl.find env key with Not_found -> assert false
exception Error of string
(* Accumulate all META, LINK and similar tags that appear in the preamble
in order to output them in the preamble of every generated page. *)
let header_buff = CutOut.create_buff "header-buf"
let style_buff = CutOut.create_buff "style-buf"
let common_headers = ref ""
and link_style = ref ""
let adjoin_to_header s = CutOut.put header_buff s
and adjoin_to_header_char c = CutOut.put_char header_buff c
let finalize_header () =
if not (CutOut.is_empty style_buff) then begin
let css_name = Printf.sprintf "%s.css" !name in
link_style :=
Printf.sprintf
"\n"
css_name ;
adjoin_to_header !link_style ;
let chan = real_open_out css_name in
output_string chan (CutOut.to_string style_buff) ;
close_out chan
end ;
common_headers := CutOut.to_string header_buff
let html_buff = CutOut.create_buff "html-buf"
let html_head = ref ""
and html_foot = ref ""
and html_prefix = ref ""
let phase = ref (-1)
;;
let body = ref ""
and doctype = ref ""
and html = ref ""
;;
let new_filename s =
incr count ;
Printf.sprintf "%s%0.3d.html" !name !count
let out = ref (CutOut.create_null ())
and out_prefix = ref (CutOut.create_null ())
and outname = ref ""
and lastclosed = ref ""
and otheroutname = ref ""
and flowname_stack = (Stack.create "flowname" : string Stack.t)
and flow_stack = (Stack.create "flow" : CutOut.t Stack.t)
;;
let toc = ref !out
and tocname = ref !outname
and otherout = ref !out
;;
let close_loc ctx name out = CutOut.close out
let change_name oldname name =
if !phase <= 0 then begin
if !verbose > 0 then
prerr_endline ("Change "^oldname^" into "^name) ;
record_changed oldname name ;
end
let start_phase name =
incr phase ;
if !verbose > 0 then
prerr_endline ("Starting phase number: "^string_of_int !phase);
outname := name ;
tocname := name ;
otheroutname := "" ;
count := 0 ;
if !phase = 0 then begin
let d = Filename.dirname name in
if d <> "." then begin
base := Some d
end
end ;
if !phase > 0 then begin
out := CutOut.create_chan (real_name name)
end ;
toc := !out
;;
let openlist out =
(* Printf.eprintf "OPEN LIST: %s\n" (CutOut.get_name out) ; *)
CutOut.put out "
\n"
and closelist out =
(* Printf.eprintf "CLOSE LIST: %s\n" (CutOut.get_name out) ; *)
CutOut.put out "
\n"
and itemref filename s out =
let filename = check_changed filename in
CutOut.put out "
\n"
;;
let delayed_anchor = ref false
and prev_anchor = ref None
let do_putanchor label out =
CutOut.put out ""
;;
let putanchor label out =
if !delayed_anchor then
prev_anchor := Some (label, out)
else
do_putanchor label out
and really_putanchor () =
if !phase = 0 then
delayed_anchor := true
else match !prev_anchor with
| Some (label, out) ->
do_putanchor label out ;
prev_anchor := None
| None -> ()
let putlink out name txt =
let name = check_changed name in
CutOut.put out "" ;
CutOut.put out txt ;
CutOut.put out "\n"
;;
let link_buff = CutOut.create_buff "link-buf"
let putlinks name =
let links_there = ref false in
if !verbose > 0 then
prerr_endline ("putlinks: "^name) ;
begin try
putlink link_buff (Thread.prev name) (get_env "PREVTXT") ;
links_there := true
with Not_found ->
if !verbose > 0 then
prerr_endline ("No prev link for "^name)
end ;
begin try
putlink link_buff (Thread.up name) (get_env "UPTXT") ;
links_there := true
with Not_found -> () end ;
begin try
putlink link_buff (Thread.next name) (get_env "NEXTTXT") ;
links_there := true
with Not_found -> () end ;
if !links_there then
Some (CutOut.to_string link_buff)
else
None
let putlinks_start out outname =
if !cross_links then
match putlinks outname with
| Some s ->
some_links := true ;
CutOut.put out s ;
CutOut.put out "\n"
| None -> ()
let putlinks_end out outname =
if !cross_links then
match putlinks outname with
| Some s ->
some_links := true ;
CutOut.put out "\n" ;
CutOut.put out s
| None -> ()
let openhtml withlinks title out outname =
CutOut.put out !doctype ; CutOut.put_char out '\n' ;
CutOut.put out !html ; CutOut.put_char out '\n' ;
CutOut.put out "\n" ;
CutOut.put out !common_headers;
CutOut.put out "" ;
let title = Save.tagout (Lexing.from_string (!html_prefix^title)) in
CutOut.put out title ;
CutOut.put out "\n" ;
CutOut.put out "\n" ;
CutOut.put out !body;
CutOut.put out "\n" ;
if withlinks then putlinks_start out outname ;
CutOut.put out !html_head
and closehtml withlinks name out =
CutOut.put out !html_foot ;
if withlinks then begin
putlinks_end out name
end ;
CutOut.put out "\n" ;
CutOut.put out "\n" ;
close_loc "closehtml" name out
;;
let put_sec hd title hde out =
CutOut.put out hd ;
CutOut.put_char out '\n' ;
CutOut.put out title ;
CutOut.put out hde ;
CutOut.put_char out '\n'
;;
let put s = CutOut.put !out s
and put_char c = CutOut.put_char !out c
;;
let cur_level = ref (Section.value "DOCUMENT")
and chapter = ref (Section.value "CHAPTER")
and depth = ref 2
;;
(* Open all lists in toc from chapter to sec, with sec > chapter *)
let rec do_open l1 l2 =
if l1 < l2 then begin
begin match !toc_style with
| Both -> openlist !toc ; openlist !out_prefix
| Special -> openlist !out_prefix
| Normal -> openlist !toc
end ;
do_open (l1+1) l2
end
;;
(* close from l1 down to l2 *)
let rec do_close l1 l2 =
if l1 > l2 then begin
begin match !toc_style with
| Both -> closelist !toc ; closelist !out_prefix
| Special -> closelist !out_prefix
| Normal -> closelist !toc
end ;
do_close (l1-1) l2
end else
cur_level := l1
;;
let anchor = ref 0
;;
let open_section sec name =
if !phase > 0 then begin
if !cur_level > sec then do_close !cur_level sec
else if !cur_level < sec then do_open !cur_level sec ;
incr anchor ;
let label = "toc"^string_of_int !anchor in
begin match !toc_style with
| Normal ->
itemanchor !outname label name !toc ;
| Both ->
itemanchor !outname label name !toc ;
itemanchor !outname label name !out_prefix
| Special ->
itemanchor !outname label name !out_prefix
end ;
putanchor label !out ;
cur_level := sec
end else
cur_level := sec
and close_section sec =
if !phase > 0 then do_close !cur_level sec
else
cur_level := sec
;;
let close_chapter () =
if !verbose > 0 then
prerr_endline ("Close chapter out="^ !outname^" toc="^ !tocname) ;
if !phase > 0 then begin
if !outname <> !tocname then closehtml true !outname !out ;
begin match !toc_style with
| Both|Special ->
let real_out = real_open_out !outname in
CutOut.to_chan real_out !out_prefix ;
CutOut.to_chan real_out !out ;
close_out real_out
| Normal -> ()
end ;
out := !toc
end else begin
lastclosed := !outname ;
outname := !tocname
end
and open_chapter name =
outname := new_filename ("open_chapter <<"^name^">>") ;
if !verbose > 0 then
prerr_endline
("Open chapter out="^ !outname^" toc="^ !tocname^
" cur_level="^string_of_int !cur_level) ;
if !phase > 0 then begin
begin match !toc_style with
| Both|Special ->
out_prefix := CutOut.create_buff (!outname ^ "-prefix") ;
out := !out_prefix ;
openhtml true name !out_prefix !outname
| Normal ->
out := CutOut.create_chan (real_name !outname) ;
openhtml true name !out !outname
end ;
itemref !outname name !toc ;
cur_level := !chapter
end else begin
if !verbose > 0 then
prerr_endline ("link prev="^ !lastclosed^" next="^ !outname) ;
Thread.setup !outname !tocname ;
Thread.setprevnext !lastclosed !outname ;
cur_level := !chapter
end
;;
let setlink set target =
if !phase = 0 && target <> "" then
set !outname target
let open_notes_pred sec_notes =
if sec_notes = !chapter then
!cur_level < sec_notes
else if sec_notes < !chapter then
!chapter < !cur_level
else
true
let open_notes sticky sec_notes =
if !verbose > 0 && !phase > 0 then
Printf.eprintf "Notes flushed as %s (current cut is %s, current level is %s)\n"
(Section.pretty sec_notes)
(Section.pretty !chapter)
(Section.pretty !cur_level) ;
if
not sticky && open_notes_pred sec_notes
then begin
otheroutname := !outname ;
outname := new_filename "open_notes" ;
if !phase > 0 then begin
otherout := !out ;
out := CutOut.create_chan (real_name !outname) ;
CutOut.put !out !doctype ; CutOut.put_char !out '\n' ;
CutOut.put !out !html ; CutOut.put_char !out '\n' ;
CutOut.put !out "Notes\n" ;
CutOut.put !out !common_headers ;
CutOut.put !out "\n" ;
CutOut.put !out !body ;
CutOut.put !out "\n"
end
end else
otheroutname := ""
and close_notes () =
if !otheroutname <> "" then begin
CutOut.put !out "\n