1(* camlp5r ./pa_html.cmo *) 2(* $Id: wiki.ml,v 5.31 2007-09-12 09:58:44 ddr Exp $ *) 3(* Copyright (c) 1998-2007 INRIA *) 4 5open Config; 6open Hutil; 7open Printf; 8open Util; 9 10(* TLSW: Text Language Stolen to Wikipedia 11 = title level 1 = 12 == title level 2 == 13 ... 14 ====== title level 6 ====== 15 * list ul/li item 16 * list ul/li item 17 ** list ul/li item 2nd level 18 ** list ul/li item 2nd level 19 ... 20 # list ol/li item 21 : indentation list dl/dd item 22 ; list dl dt item ; dd item 23 ''italic'' 24 '''bold''' 25 '''''bold+italic''''' 26 [[first_name/surname/oc/text]] link; 'text' displayed 27 [[first_name/surname/text]] link (oc = 0); 'text' displayed 28 [[first_name/surname]] link (oc = 0); 'first_name surname' displayed 29 [[[notes_subfile/text]]] link to a sub-file; 'text' displayed 30 [[[notes_subfile]]] link to a sub-file; 'notes_subfile' displayed 31 empty line : new paragraph 32 lines starting with space : displayed as they are (providing 1/ there 33 are at least two 2/ there is empty lines before and after the group 34 of lines). 35 __TOC__ : summary 36 __SHORT_TOC__ : short summary (unnumbered) 37 __NOTOC__ : no (automatic) numbered summary *) 38 39module Buff2 = Buff.Make (struct value buff = ref (Bytes.create 80); end); 40module Buff = Buff.Make (struct value buff = ref (Bytes.create 80); end); 41 42value first_cnt = 1; 43 44value tab lev s = String.make (2 * lev) ' ' ^ s; 45 46value section_level s len = 47 loop 1 (len - 2) 4 where rec loop i j k = 48 if i > 5 then i 49 else if len > k && s.[i] = '=' && s.[j] = '=' then 50 loop (i + 1) (j - 1) (k + 2) 51 else i 52; 53 54value notes_aliases conf = 55 let fname = 56 match p_getenv conf.base_env "notes_alias_file" with 57 [ Some f -> Util.base_path [] f 58 | None -> 59 Filename.concat (Util.base_path [] (conf.bname ^ ".gwb")) 60 "notes.alias" ] 61 in 62 match try Some (Secure.open_in fname) with [ Sys_error _ -> None ] with 63 [ Some ic -> 64 loop [] where rec loop list = 65 match try Some (input_line ic) with [ End_of_file -> None ] with 66 [ Some s -> 67 let list = 68 try 69 let i = String.index s ' ' in 70 [(String.sub s 0 i, 71 String.sub s (i + 1) (String.length s - i - 1)) :: list] 72 with 73 [ Not_found -> list ] 74 in 75 loop list 76 | None -> do { close_in ic; list } ] 77 | None -> [] ] 78; 79 80value map_notes aliases f = 81 try List.assoc f aliases with [ Not_found -> f ] 82; 83 84value fname_of_path (dirs, file) = List.fold_right Filename.concat dirs file; 85 86value str_start_with str i x = 87 loop i 0 where rec loop i j = 88 if j = String.length x then True 89 else if i = String.length str then False 90 else if str.[i] = x.[j] then loop (i + 1) (j + 1) 91 else False 92; 93 94type wiki_info = 95 { wi_mode : string; 96 wi_file_path : string -> string; 97 wi_cancel_links : bool; 98 wi_person_exists : (string * string * int) -> bool; 99 wi_always_show_link : bool } 100; 101 102value syntax_links conf wi s = 103 let slen = String.length s in 104 loop 0 1 0 0 where rec loop quot_lev pos i len = 105 let (len, quot_lev) = 106 if i = slen || List.exists (str_start_with s i) ["</li>"; "</p>"] then 107 let len = 108 match quot_lev with 109 [ 1 -> Buff.mstore len "</i>" 110 | 2 -> Buff.mstore len "</b>" 111 | 3 -> Buff.mstore len "</b></i>" 112 | _ -> len ] 113 in 114 (len, 0) 115 else (len, quot_lev) 116 in 117 if i = slen then Buff.get len 118 else if 119 s.[i] = '%' && i < slen - 1 && List.mem s.[i+1] ['['; ']'; '{'; '}'; '''] 120 then 121 loop quot_lev pos (i + 2) (Buff.store len s.[i+1]) 122 else if s.[i] = '%' && i < slen - 1 && s.[i+1] = '/' then 123 loop quot_lev pos (i + 2) (Buff.mstore len conf.xhs) 124 else if s.[i] = '{' then 125 let (b, j) = 126 loop 0 (i + 1) where rec loop len j = 127 if j = slen then (Buff2.get len, j) 128 else if j < slen - 1 && s.[j] = '%' then 129 loop (Buff2.store len s.[j+1]) (j + 2) 130 else if s.[j] = '}' then (Buff2.get len, j + 1) 131 else loop (Buff2.store len s.[j]) (j + 1) 132 in 133 let s = sprintf "<span class=\"highlight\">%s</span>" b in 134 loop quot_lev pos j (Buff.mstore len s) 135(* 136interesting idea, but perhaps dangerous (risk of hidden messages and 137use of database forum by ill-intentioned people to communicate)... 138 else if str_start_with s i "[\n" then 139 let j = 140 try String.index_from s (i+2) ']' + 1 with [ Not_found -> slen ] 141 in 142 let b = String.sub s (i + 2) (j - i - 3) in 143 let (tb, _) = Translate.inline conf.lang '%' (String.make 1) b in 144 loop quot_lev pos j (Buff.mstore len tb) 145*) 146 else if 147 i <= slen - 5 && s.[i] = ''' && s.[i+1] = ''' && s.[i+2] = ''' && 148 s.[i+3] = ''' && s.[i+4] = ''' && (quot_lev = 0 || quot_lev = 3) 149 then 150 let s = if quot_lev = 0 then "<i><b>" else "</b></i>" in 151 loop (3 - quot_lev) pos (i + 5) (Buff.mstore len s) 152 else if 153 i <= slen - 3 && s.[i] = ''' && s.[i+1] = ''' && s.[i+2] = ''' && 154 (quot_lev = 0 || quot_lev = 2) 155 then 156 let s = if quot_lev = 0 then "<b>" else "</b>" in 157 loop (2 - quot_lev) pos (i + 3) (Buff.mstore len s) 158 else if 159 i <= slen - 2 && s.[i] = ''' && s.[i+1] = ''' && 160 (quot_lev = 0 || quot_lev = 1) 161 then 162 let s = if quot_lev = 0 then "<i>" else "</i>" in 163 loop (1 - quot_lev) pos (i + 2) (Buff.mstore len s) 164 else 165 match NotesLinks.misc_notes_link s i with 166 [ NotesLinks.WLpage j fpath1 fname1 anchor text -> 167 let (fpath, fname) = 168 let aliases = notes_aliases conf in 169 let fname = map_notes aliases fname1 in 170 match NotesLinks.check_file_name fname with 171 [ Some fpath -> (fpath, fname) 172 | None -> (fpath1, fname1) ] 173 in 174 let c = 175 let f = wi.wi_file_path (fname_of_path fpath) in 176 if Sys.file_exists f then "" else " style=\"color:red\"" 177 in 178 let t = 179 if wi.wi_cancel_links then text 180 else 181 sprintf "<a href=\"%sm=%s;f=%s%s\"%s>%s</a>" 182 (commd conf) wi.wi_mode fname anchor c text 183 in 184 loop quot_lev pos j (Buff.mstore len t) 185 | NotesLinks.WLperson j (fn, sn, oc) name _ -> 186 let t = 187 if wi.wi_cancel_links then name 188 else if wi.wi_person_exists (fn, sn, oc) then 189 sprintf "<a id=\"p_%d\" href=\"%sp=%s;n=%s%s\">%s</a>" 190 pos (commd conf) (code_varenv fn) (code_varenv sn) 191 (if oc = 0 then "" else ";oc=" ^ string_of_int oc) name 192 else if wi.wi_always_show_link then 193 let s = " style=\"color:red\"" in 194 sprintf "<a id=\"p_%d\" href=\"%sp=%s;n=%s%s\"%s>%s</a>" 195 pos (commd conf) (code_varenv fn) (code_varenv sn) 196 (if oc = 0 then "" else ";oc=" ^ string_of_int oc) s name 197 else 198 sprintf "<a href=\"%s\" style=\"color:red\">%s</a>" (commd conf) 199 (if conf.hide_names then "x x" else name) 200 in 201 loop quot_lev (pos + 1) j (Buff.mstore len t) 202 | NotesLinks.WLwizard j wiz name -> 203 let t = 204 let s = if name <> "" then name else wiz in 205 if wi.wi_cancel_links then s 206 else 207 sprintf "<a href=\"%sm=WIZNOTES;f=%s\">%s</a>" (commd conf) wiz 208 s 209 in 210 loop quot_lev (pos + 1) j (Buff.mstore len t) 211 | NotesLinks.WLnone -> 212 loop quot_lev pos (i + 1) (Buff.store len s.[i]) ] 213; 214 215value toc_list = ["__NOTOC__"; "__TOC__"; "__SHORT_TOC__"]; 216 217value lines_list_of_string s = 218 loop False [] 0 0 where rec loop no_toc lines len i = 219 if i = String.length s then 220 (List.rev (if len = 0 then lines else [Buff.get len :: lines]), no_toc) 221 else if s.[i] = '\n' then 222 let line = Buff.get len in 223 let no_toc = List.mem line toc_list || no_toc in 224 loop no_toc [line :: lines] 0 (i + 1) 225 else 226 loop no_toc lines (Buff.store len s.[i]) (i + 1) 227; 228 229value adjust_ul_level rev_lines old_lev new_lev = 230 if old_lev < new_lev then [tab (old_lev + 1) "<ul>" :: rev_lines] 231 else 232 let rev_lines = [List.hd rev_lines ^ "</li>" :: List.tl rev_lines] in 233 loop rev_lines old_lev where rec loop rev_lines lev = 234 if lev = new_lev then rev_lines 235 else loop [tab lev "</ul></li>" :: rev_lines] (lev - 1) 236; 237 238value message_txt conf i = transl_nth conf "visualize/show/hide/summary" i; 239 240value sections_nums_of_tlsw_lines lines = 241 let (lev, _, cnt, rev_sections_nums) = 242 List.fold_left 243 (fun (prev_lev, indent_stack, cnt, sections_nums) s -> 244 let len = String.length s in 245 if len > 2 && s.[0] = '=' && s.[len-1] = '=' then 246 let slev = section_level s len in 247 let (lev, stack) = 248 loop prev_lev indent_stack where rec loop lev stack = 249 match stack with 250 [ [(prev_num, prev_slev) :: rest_stack] -> 251 if slev < prev_slev then 252 match rest_stack with 253 [ [(_, prev_prev_slev) :: _] -> 254 if slev > prev_prev_slev then 255 let stack = [(prev_num, slev) :: rest_stack] in 256 loop lev stack 257 else 258 loop (lev - 1) rest_stack 259 | [] -> 260 let stack = [(prev_num + 1, slev) :: rest_stack] in 261 (lev - 1, stack) ] 262 else if slev = prev_slev then 263 let stack = [(prev_num + 1, slev) :: rest_stack] in 264 (lev - 1, stack) 265 else 266 let stack = [(1, slev) :: stack] in 267 (lev, stack) 268 | [] -> 269 let stack = [(1, slev) :: stack] in 270 (lev, stack) ] 271 in 272 let section_num = 273 let nums = List.map fst stack in 274 String.concat "." (List.rev_map string_of_int nums) 275 in 276 (lev + 1, stack, cnt + 1, [(lev, section_num) :: sections_nums]) 277 else (prev_lev, indent_stack, cnt, sections_nums)) 278 (0, [], first_cnt, []) lines 279 in 280 List.rev rev_sections_nums 281; 282 283value remove_links s = 284 loop 0 0 where rec loop len i = 285 if i = String.length s then Buff.get len 286 else 287 let (len, i) = 288 match NotesLinks.misc_notes_link s i with 289 [ NotesLinks.WLpage j _ _ _ text -> (Buff.mstore len text, j) 290 | NotesLinks.WLperson j k name text -> 291 let text = 292 match text with 293 [ Some text -> if text = "" then name else text 294 | None -> name ] 295 in 296 (Buff.mstore len text, j) 297 | NotesLinks.WLwizard j _ text -> (Buff.mstore len text, j) 298 | NotesLinks.WLnone -> (Buff.store len s.[i], i + 1) ] 299 in 300 loop len i 301; 302 303value summary_of_tlsw_lines conf short lines = 304 let sections_nums = sections_nums_of_tlsw_lines lines in 305 let (rev_summary, lev, cnt, _) = 306 List.fold_left 307 (fun (summary, prev_lev, cnt, sections_nums) s -> 308 let s = remove_links s in 309 let len = String.length s in 310 if len > 2 && s.[0] = '=' && s.[len-1] = '=' then 311 let slev = section_level s len in 312 let (lev, section_num, sections_nums) = 313 match sections_nums with 314 [ [(lev, sn) :: sns] -> (lev, sn, sns) 315 | [] -> (0, "fuck", []) ] 316 in 317 let summary = 318 let s = 319 sprintf "<a href=\"#a_%d\">%s%s</a>" cnt 320 (if short then "" else section_num ^ " - ") 321 (Gutil.strip_spaces (String.sub s slev (len - 2 * slev))) 322 in 323 if short then 324 if summary = [] then [s] else [s; ";" :: summary] 325 else 326 let line = tab (lev + 1) "<li>" ^ s in 327 [line :: adjust_ul_level summary (prev_lev - 1) lev] 328 in 329 (summary, lev + 1, cnt + 1, sections_nums) 330 else 331 (summary, prev_lev, cnt, sections_nums)) 332 ([], 0, first_cnt, sections_nums) lines 333 in 334 if cnt <= first_cnt + 2 then 335 (* less that 3 paragraphs : summary abandonned *) 336 ([], []) 337 else 338 let rev_summary = 339 if short then rev_summary 340 else ["</ul>" :: adjust_ul_level rev_summary (lev - 1) 0] 341 in 342 let lines = 343 ["<dl><dd>"; 344 "<table id=\"summary\" cellpadding=\"10\">"; 345 "<tr><td align=\"" ^ conf.left ^ "\">"; 346 "<div style=\"text-align:center\"><b>" ^ 347 capitale (message_txt conf 3) ^ "</b>"; 348 "<script type=\"text/javascript\">"; 349 "//<![CDATA["; 350 "showTocToggle()"; 351 "//]]>"; 352 "</script>"; 353 "</div>"; 354 "<div class=\"summary\" id=\"tocinside\">" :: 355 List.rev_append rev_summary 356 ["</div>"; 357 "</td></tr></table>"; 358 "</dd></dl>"; 359 "<script type=\"text/javascript\">"; 360 "//<![CDATA["; 361 "setTocToggle()"; 362 "//]]>"; 363 "</script>"]] 364 in 365 (lines, sections_nums) 366; 367 368value string_of_modify_link conf cnt empty = 369 fun 370 [ Some (can_edit, mode, sfn) -> 371 if conf.wizard then 372 let mode_pref = if can_edit then "MOD" else "VIEW" in 373 sprintf "%s(<a href=\"%sm=%s_%s;v=%d%s\">%s</a>)%s\n" 374 (if empty then "<p>" 375 else 376 sprintf "<div style=\"font-size:80%%;float:%s;margin-%s:3em\">" 377 conf.right conf.left) 378 (commd conf) mode_pref mode cnt (if sfn = "" then "" else ";f=" ^ sfn) 379 (if can_edit then transl_decline conf "modify" "" 380 else transl conf "view source") 381 (if empty then "</p>" else "</div>") 382 else "" 383 | None -> "" ] 384; 385 386value rec tlsw_list tag1 tag2 lev list sl = 387 let btag2 = "<" ^ tag2 ^ ">" in 388 let etag2 = "</" ^ tag2 ^ ">" in 389 let list = [tab lev ("<" ^ tag1 ^ ">") :: list] in 390 let list = 391 loop list sl where rec loop list = 392 fun 393 [ [s1 :: ([s2 :: _] as sl)] -> 394 if String.length s2 > 0 && List.mem s2.[0] ['*'; '#'; ':'; ';'] then 395 let list = [tab lev btag2 ^ s1 :: list] in 396 let (list, sl) = do_sub_list s2.[0] lev list sl in 397 loop [tab lev etag2 :: list] sl 398 else 399 let (s1, ss1) = sub_sub_list lev tag2 s1 in 400 loop [tab lev btag2 ^ s1 ^ etag2 ^ ss1 :: list] sl 401 | [s1] -> 402 let (s1, ss1) = sub_sub_list lev tag2 s1 in 403 [tab lev btag2 ^ s1 ^ etag2 ^ ss1 :: list] 404 | [] -> list ] 405 in 406 [tab lev ("</" ^ tag1 ^ ">") :: list] 407and sub_sub_list lev tag2 s1 = 408 if tag2 = "dt" && String.contains s1 ':' then 409 let i = String.index s1 ':' in 410 let s = String.sub s1 0 i in 411 let ss = 412 "\n" ^ tab (lev + 1) "<dd>" ^ 413 String.sub s1 (i + 1) (String.length s1 - i - 1) ^ 414 "</dd>" 415 in 416 (s, ss) 417 else (s1, "") 418and do_sub_list prompt lev list sl = 419 let (tag1, tag2) = 420 match prompt with 421 [ '*' -> ("ul", "li") 422 | '#' -> ("ol", "li") 423 | ':' -> ("dl", "dd") 424 | ';' -> ("dl", "dt") 425 | _ -> assert False ] 426 in 427 let (list2, sl) = 428 loop [] sl where rec loop list = 429 fun 430 [ [s :: sl] -> 431 if String.length s > 0 && s.[0] = prompt then 432 let s = String.sub s 1 (String.length s - 1) in 433 loop [s :: list] sl 434 else (list, [s :: sl]) 435 | [] -> (list, []) ] 436 in 437 let list = tlsw_list tag1 tag2 (lev + 1) list (List.rev list2) in 438 match sl with 439 [ [s :: _] -> 440 if String.length s > 0 && List.mem s.[0] ['*'; '#'; ':'; ';'] then 441 do_sub_list s.[0] lev list sl 442 else (list, sl) 443 | [] -> (list, sl) ] 444; 445 446value rec hotl conf wlo cnt edit_opt sections_nums list = 447 fun 448 [ ["__NOTOC__" :: sl] -> hotl conf wlo cnt edit_opt sections_nums list sl 449 | ["__TOC__" :: sl] -> 450 let list = 451 match wlo with 452 [ Some lines -> 453 let (summary, _) = summary_of_tlsw_lines conf False lines in 454 List.rev_append summary list 455 | None -> list ] 456 in 457 hotl conf wlo cnt edit_opt sections_nums list sl 458 | ["__SHORT_TOC__" :: sl] -> 459 let list = 460 match wlo with 461 [ Some lines -> 462 let (summary, _) = summary_of_tlsw_lines conf True lines in 463 List.rev_append summary list 464 | None -> list ] 465 in 466 hotl conf wlo cnt edit_opt sections_nums list sl 467 | ["" :: sl] -> 468 let parag = 469 let rec loop1 parag = 470 fun 471 [ ["" :: sl] -> Some (parag, sl, True) 472 | [s :: sl] -> 473 if List.mem s.[0] ['*'; '#'; ':'; ';'; '='] || 474 List.mem s toc_list 475 then 476 if parag = [] then None else Some (parag, [s :: sl], True) 477 else if s.[0] = ' ' && parag = [] then 478 loop2 [s] sl 479 else loop1 [s :: parag] sl 480 | [] -> Some (parag, [], True) ] 481 and loop2 parag = 482 fun 483 [ ["" :: sl] -> Some (parag, sl, False) 484 | [s :: sl] -> 485 if s.[0] = ' ' then loop2 [s :: parag] sl 486 else loop1 parag [s :: sl] 487 | [] -> Some (parag, [], True) ] 488 in 489 loop1 [] sl 490 in 491 let (list, sl) = 492 match parag with 493 [ Some ([], _, _) | None -> (list, sl) 494 | Some (parag, sl, False) when List.length parag >= 2 -> 495 (["</pre>" :: parag @ ["<pre>" :: list]], ["" :: sl]) 496 | Some (parag, sl, _) -> 497 (["</p>" :: parag @ ["<p>" :: list]], ["" :: sl]) ] 498 in 499 hotl conf wlo cnt edit_opt sections_nums list sl 500 | [s :: sl] -> 501 let len = String.length s in 502 let tago = 503 if len > 0 then 504 match s.[0] with 505 [ '*' -> Some ("ul", "li") 506 | '#' -> Some ("ol", "li") 507 | ':' -> Some ("dl", "dd") 508 | ';' -> Some ("dl", "dt") 509 | _ -> None ] 510 else None 511 in 512 match tago with 513 [ Some (tag1, tag2) -> 514 let (sl, rest) = select_list_lines conf s.[0] [] [s :: sl] in 515 let list = tlsw_list tag1 tag2 0 list sl in 516 hotl conf wlo cnt edit_opt sections_nums list ["" :: rest] 517 | None -> 518 if len > 2 && s.[0] = '=' && s.[len-1] = '=' then 519 let slev = section_level s len in 520 let (section_num, sections_nums) = 521 match sections_nums with 522 [ [(_, a) :: l] -> (a ^ " - ", l) 523 | [] -> ("", []) ] 524 in 525 let s = 526 let style = 527 if slev <= 3 then " class=\"subtitle\"" 528 else "" 529 in 530 sprintf "<h%d%s>%s%s</h%d>" slev style section_num 531 (String.sub s slev (len-2*slev)) slev 532 in 533 let list = 534 if wlo <> None then 535 let s = sprintf "<p><a id=\"a_%d\"></a></p>" cnt in 536 [s:: list] 537 else list 538 in 539 let list = 540 let s = string_of_modify_link conf cnt False edit_opt in 541 if s = "" then list else [s :: list] 542 in 543 hotl conf wlo (cnt + 1) edit_opt sections_nums list [s :: sl] 544 else 545 hotl conf wlo cnt edit_opt sections_nums [s :: list] sl ] 546 | [] -> List.rev list ] 547and select_list_lines conf prompt list = 548 fun 549 [ [s :: sl] -> 550 let len = String.length s in 551 if len > 0 && s.[0] = '=' then (List.rev list, [s :: sl]) 552 else if len > 0 && s.[0] = prompt then 553 let s = String.sub s 1 (len - 1) in 554 let (s, sl) = 555 loop s sl where rec loop s1 = 556 fun 557 [ [""; s :: sl] 558 when String.length s > 1 && s.[0] = prompt && s.[1] = prompt -> 559 let br = "<br" ^ conf.xhs ^ ">" in 560 loop (s1 ^ br ^ br) [s :: sl] 561 | [s :: sl] -> 562 if String.length s > 0 && s.[0] = '=' then (s1, [s :: sl]) 563 else if String.length s > 0 && s.[0] <> prompt then 564 loop (s1 ^ "\n" ^ s) sl 565 else (s1, [s :: sl]) 566 | [] -> (s1, []) ] 567 in 568 select_list_lines conf prompt [s :: list] sl 569 else (List.rev list, [s :: sl]) 570 | [] -> (List.rev list, []) ] 571; 572 573value html_of_tlsw conf s = 574 let (lines, _) = lines_list_of_string s in 575 let sections_nums = 576 match sections_nums_of_tlsw_lines lines with 577 [ [_] -> [] 578 | l -> l ] 579 in 580 hotl conf (Some lines) first_cnt None sections_nums [] ["" :: lines] 581; 582 583value html_with_summary_of_tlsw conf wi edit_opt s = 584 let (lines, no_toc) = lines_list_of_string s in 585 let (summary, sections_nums) = 586 if no_toc then ([], []) else summary_of_tlsw_lines conf False lines 587 in 588 let (rev_lines_before_summary, lines) = 589 loop [] lines where rec loop lines_bef = 590 fun 591 [ [s :: sl] -> 592 if String.length s > 1 && s.[0] = '=' then (lines_bef, [s :: sl]) 593 else loop [s :: lines_bef] sl 594 | [] -> (lines_bef, []) ] 595 in 596 let lines_before_summary = 597 hotl conf (Some lines) first_cnt None [] [] 598 (List.rev rev_lines_before_summary) 599 in 600 let lines_after_summary = 601 hotl conf (Some lines) first_cnt edit_opt sections_nums [] lines 602 in 603 let s = 604 syntax_links conf wi 605 (String.concat "\n" 606 (lines_before_summary @ summary @ lines_after_summary)) 607 in 608 if lines_before_summary <> [] || lines = [] then 609 let s2 = string_of_modify_link conf 0 (s = "") edit_opt in 610 s2 ^ "<p><br" ^ conf.xhs ^ "></p>\n" ^ s 611 else s 612; 613 614value rev_extract_sub_part s v = 615 let (lines, _) = lines_list_of_string s in 616 loop [] 0 first_cnt lines where rec loop lines lev cnt = 617 fun 618 [ [s :: sl] -> 619 let len = String.length s in 620 if len > 2 && s.[0] = '=' && s.[len-1] = '=' then 621 if v = first_cnt - 1 then lines 622 else 623 let nlev = section_level s len in 624 if cnt = v then loop [s :: lines] nlev (cnt + 1) sl 625 else if cnt > v then 626 if nlev > lev then loop [s :: lines] lev (cnt + 1) sl 627 else lines 628 else loop lines lev (cnt + 1) sl 629 else if cnt <= v then loop lines lev cnt sl 630 else loop [s :: lines] lev cnt sl 631 | [] -> lines ] 632; 633 634value extract_sub_part s v = List.rev (rev_extract_sub_part s v); 635 636value print_sub_part_links conf edit_mode sfn cnt0 is_empty = 637 tag "p" begin 638 if cnt0 >= first_cnt then 639 stagn "a" "href=\"%sm=%s%s;v=%d\"" (commd conf) edit_mode sfn (cnt0 - 1) 640 begin 641 Wserver.wprint "<<"; 642 end 643 else (); 644 stagn "a" "href=\"%sm=%s%s\"" (commd conf) edit_mode sfn begin 645 Wserver.wprint "^^"; 646 end; 647 if not is_empty then 648 stagn "a" "href=\"%sm=%s%s;v=%d\"" (commd conf) edit_mode sfn (cnt0 + 1) 649 begin 650 Wserver.wprint ">>"; 651 end 652 else (); 653 end 654; 655 656value print_sub_part_text conf wi edit_opt cnt0 lines = 657 let lines = 658 List.map 659 (fun 660 [ "__TOC__" | "__SHORT_TOC__" -> 661 sprintf "<p>...%s...</p>" (message_txt conf 3) 662 | "__NOTOC__" -> "" 663 | s -> s ]) 664 lines 665 in 666 let lines = hotl conf None cnt0 edit_opt [] [] lines in 667 let s = String.concat "\n" lines in 668 let s = syntax_links conf wi s in 669 let s = 670 if cnt0 < first_cnt then 671 let s2 = string_of_modify_link conf 0 (s = "") edit_opt in 672 s2 ^ s 673 else s 674 in 675 Wserver.wprint "%s\n" s 676; 677 678value print_sub_part conf wi can_edit edit_mode sub_fname cnt0 679 lines = 680 let edit_opt = Some (can_edit, edit_mode, sub_fname) in 681 let sfn = if sub_fname = "" then "" else ";f=" ^ sub_fname in 682 do { 683 print_sub_part_links conf edit_mode sfn cnt0 (lines = []); 684 print_sub_part_text conf wi edit_opt cnt0 lines; 685 } 686; 687 688value print_mod_view_page conf can_edit mode fname title env s = do { 689 let s = 690 List.fold_left (fun s (k, v) -> s ^ k ^ "=" ^ v ^ "\n") "" env ^ s 691 in 692 let mode_pref = if can_edit then "MOD_" else "VIEW_" in 693 let (has_v, v) = 694 match p_getint conf.env "v" with 695 [ Some v -> (True, v) 696 | None -> (False, 0) ] 697 in 698 let sub_part = 699 if not has_v then s else String.concat "\n" (extract_sub_part s v) 700 in 701 let is_empty = sub_part = "" in 702 let sfn = if fname = "" then "" else ";f=" ^ code_varenv fname in 703 header conf title; 704 if can_edit then 705 tag "div" "style=\"font-size:80%%;float:%s;margin-%s:3em\"" conf.right 706 conf.left 707 begin 708 Wserver.wprint "("; 709 stag "a" "href=\"%sm=%s%s%s\"" (commd conf) mode 710 (if has_v then ";v=" ^ string_of_int v else "") sfn 711 begin 712 Wserver.wprint "%s" (message_txt conf 0); 713 end; 714 Wserver.wprint ")\n"; 715 end 716 else (); 717 print_link_to_welcome conf (if can_edit then False else True); 718 if can_edit && has_v then 719 print_sub_part_links conf (mode_pref ^ mode) sfn v is_empty 720 else (); 721 tag "form" "method=\"post\" action=\"%s\"" conf.command begin 722 tag "p" begin 723 Util.hidden_env conf; 724 if can_edit then 725 xtag "input" "type=\"hidden\" name=\"m\" value=\"MOD_%s_OK\"" mode 726 else (); 727 if has_v then 728 xtag "input" "type=\"hidden\" name=\"v\" value=\"%d\"" v 729 else (); 730 if fname <> "" then 731 xtag "input" "type=\"hidden\" name=\"f\" value=\"%s\"" fname 732 else (); 733 if can_edit then 734 let digest = Iovalue.digest s in 735 xtag "input" "type=\"hidden\" name=\"digest\" value=\"%s\"" digest 736 else (); 737 begin_centered conf; 738 tag "table" "border=\"1\"" begin 739 tag "tr" begin 740 tag "td" begin 741 tag "table" begin 742 match Util.open_etc_file "toolbar" with 743 [ Some ic -> 744 tag "tr" begin 745 tag "td" begin 746 Templ.copy_from_templ conf [("name", "notes")] ic; 747 end; 748 end 749 | None -> () ]; 750 tag "tr" begin 751 tag "td" begin 752 stag "textarea" "name=\"notes\" rows=\"25\" cols=\"110\"%s" 753 (if can_edit then "" else " readonly=\"readonly\"") 754 begin 755 Wserver.wprint "%s" (quote_escaped sub_part); 756 end; 757 end; 758 end; 759 match Util.open_etc_file "accent" with 760 [ Some ic -> 761 tag "tr" begin 762 tag "td" begin 763 Templ.copy_from_templ conf [("name", "notes")] ic; 764 end; 765 end 766 | None -> () ]; 767 end; 768 if can_edit then do { 769 xtag "br"; 770 xtag "input" "type=\"submit\" value=\"Ok\""; 771 } 772 else (); 773 end; 774 end; 775 end; 776 end_centered conf; 777 end; 778 end; 779 trailer conf; 780}; 781 782value insert_sub_part s v sub_part = 783 let (lines, _) = lines_list_of_string s in 784 let (lines, sl) = 785 loop False [] 0 first_cnt lines 786 where rec loop sub_part_added lines lev cnt = 787 fun 788 [ [s :: sl] -> 789 let len = String.length s in 790 if len > 2 && s.[0] = '=' && s.[len-1] = '=' then 791 if v = first_cnt - 1 then 792 (if sub_part = "" then [] else [""; sub_part], [s :: sl]) 793 else 794 let nlev = section_level s len in 795 if cnt = v then 796 let lines = 797 if sub_part = "" then lines else [""; sub_part :: lines] 798 in 799 loop True lines nlev (cnt + 1) sl 800 else if cnt > v then 801 if nlev > lev then loop sub_part_added lines lev (cnt + 1) sl 802 else (lines, [s :: sl]) 803 else loop sub_part_added [s :: lines] lev (cnt + 1) sl 804 else if cnt <= v then loop sub_part_added [s :: lines] lev cnt sl 805 else loop sub_part_added lines lev cnt sl 806 | [] -> 807 let lines = 808 if sub_part_added then lines 809 else if sub_part = "" then lines 810 else [""; sub_part :: lines] 811 in 812 (lines, []) ] 813 in 814 String.concat "\n" (List.rev_append lines sl) 815; 816 817value rec find_env s i = 818 match 819 try Some (String.index_from s i '=', String.index_from s i '\n') with 820 [ Not_found -> None ] 821 with 822 [ Some (j, k) -> 823 if j > i && j < k then 824 let is_key = 825 loop i where rec loop i = 826 if i = j then True 827 else 828 match s.[i] with 829 [ 'A'..'Z' -> loop (i + 1) 830 | _ -> False ] 831 in 832 if is_key then 833 let key = String.sub s i (j - i) in 834 let v = String.sub s (j + 1) (k - j - 1) in 835 let (env, i) = find_env s (k + 1) in 836 ([(key, v) :: env], i) 837 else ([], i) 838 else ([], i) 839 | None -> ([], i) ] 840; 841 842value split_title_and_text s = 843 let (env, i) = find_env s 0 in 844 let s = if i = 0 then s else String.sub s i (String.length s - i) in 845 if try List.assoc "TITLE" env with [ Not_found -> "" ] = "" then 846 (* just compatibility with prev impl (could be removed at release) *) 847 let (tit, txt) = 848 try 849 let i = String.index s '\n' in 850 let tit = String.sub s 0 i in 851 let txt = String.sub s (i + 1) (String.length s - i - 1) in 852 (tit, txt) 853 with 854 [ Not_found -> (s, "") ] 855 in 856 let (tit, txt) = 857 if String.length tit > 0 && tit.[0] = '=' || String.contains tit '<' 858 || String.contains tit '[' 859 then 860 ("", s) 861 else (tit, txt) 862 in 863 let env = if tit <> "" then [("TITLE", tit) :: env] else env in 864 (env, txt) 865 else 866 (env, s) 867; 868 869value print_ok conf wi edit_mode fname title_is_1st s = 870 let title _ = 871 Wserver.wprint "%s" (Util.capitale (Util.transl conf "notes modified")) 872 in 873 do { 874 Hutil.header_no_page_title conf title; 875 tag "div" "style=\"text-align:center\"" begin 876 Wserver.wprint "--- "; 877 title (); 878 Wserver.wprint " ---\n"; 879 end; 880 Hutil.print_link_to_welcome conf True; 881 let get_v = Util.p_getint conf.env "v" in 882 let v = 883 match get_v with 884 [ Some v -> v 885 | None -> 0 ] 886 in 887 let (title, s) = 888 if v = 0 && title_is_1st then 889 let (env, s) = split_title_and_text s in 890 (try List.assoc "TITLE" env with [ Not_found -> "" ], s) 891 else ("", s) 892 in 893 let (lines, _) = lines_list_of_string s in 894 let lines = 895 if v = 0 && title <> "" then 896 let title = 897 Printf.sprintf "<h1>%s</h1>\n" title 898 in 899 [title :: lines] 900 else lines 901 in 902 print_sub_part conf wi conf.wizard edit_mode fname v lines; 903 Hutil.trailer conf 904 } 905; 906 907value print_mod_ok conf wi edit_mode fname read_string commit string_filter 908 title_is_1st = 909 let fname = fname (Util.p_getenv conf.env "f") in 910 try 911 match edit_mode fname with 912 [ Some edit_mode -> 913 let old_string = 914 let (e, s) = read_string fname in 915 List.fold_left (fun s (k, v) -> s ^ k ^ "=" ^ v ^ "\n") "" e ^ s 916 in 917 let sub_part = 918 match Util.p_getenv conf.env "notes" with 919 [ Some v -> Mutil.strip_all_trailing_spaces v 920 | None -> failwith "notes unbound" ] 921 in 922 let digest = 923 match Util.p_getenv conf.env "digest" with 924 [ Some s -> s 925 | None -> "" ] 926 in 927 if digest <> Iovalue.digest old_string then Update.error_digest conf 928 else 929 let s = 930 match Util.p_getint conf.env "v" with 931 [ Some v -> insert_sub_part old_string v sub_part 932 | None -> sub_part ] 933 in 934 do { 935 if s <> old_string then commit fname s else (); 936 let sub_part = string_filter sub_part in 937 print_ok conf wi edit_mode fname title_is_1st sub_part; 938 } 939 | None -> Hutil.incorrect_request conf ] 940 with 941 [ Update.ModErr -> () ] 942; 943