1(* camlp5r *) 2(* $Id: setup.ml,v 5.8 2007-09-12 09:58:44 ddr Exp $ *) 3 4open Printf; 5 6value port = ref 2316; 7value default_lang = ref "en"; 8value setup_dir = ref "."; 9value bin_dir = ref ""; 10value lang_param = ref ""; 11value only_file = ref ""; 12 13value slashify s = 14 let s1 = Bytes.copy s in 15 do { 16 for i = 0 to String.length s - 1 do { 17 Bytes.set s1 i 18 (match s.[i] with 19 [ '\\' -> '/' 20 | x -> x ]) 21 }; 22 s1 23 } 24; 25 26value quote_escaped s = 27 let rec need_code i = 28 if i < String.length s then 29 match s.[i] with 30 [ '"' | '&' | '<' | '>' -> True 31 | x -> need_code (succ i) ] 32 else False 33 in 34 let rec compute_len i i1 = 35 if i < String.length s then 36 let i1 = 37 match s.[i] with 38 [ '"' -> i1 + 6 39 | '&' -> i1 + 5 40 | '<' | '>' -> i1 + 4 41 | _ -> succ i1 ] 42 in 43 compute_len (succ i) i1 44 else i1 45 in 46 let rec copy_code_in s1 i i1 = 47 if i < String.length s then 48 let i1 = 49 match s.[i] with 50 [ '"' -> do { String.blit """ 0 s1 i1 6; i1 + 6 } 51 | '&' -> do { String.blit "&" 0 s1 i1 5; i1 + 5 } 52 | '<' -> do { String.blit "<" 0 s1 i1 4; i1 + 4 } 53 | '>' -> do { String.blit ">" 0 s1 i1 4; i1 + 4 } 54 | c -> do { Bytes.set s1 i1 c; succ i1 } ] 55 in 56 copy_code_in s1 (succ i) i1 57 else s1 58 in 59 if need_code 0 then 60 let len = compute_len 0 0 in copy_code_in (Bytes.create len) 0 0 61 else s 62; 63 64value rec list_remove_assoc x = 65 fun 66 [ [(x1, y1) :: l] -> 67 if x = x1 then l else [(x1, y1) :: list_remove_assoc x l] 68 | [] -> [] ] 69; 70 71value rec list_assoc_all x = 72 fun 73 [ [] -> [] 74 | [(a, b) :: l] -> 75 if a = x then [b :: list_assoc_all x l] else list_assoc_all x l ] 76; 77 78type config = 79 { lang : string; 80 comm : string; 81 env : list (string * string); 82 request : list string; 83 lexicon : Hashtbl.t string string } 84; 85 86value transl conf w = 87 try Hashtbl.find conf.lexicon w with [ Not_found -> "[" ^ w ^ "]" ] 88; 89 90value charset conf = 91 try Hashtbl.find conf.lexicon " !charset" with 92 [ Not_found -> "iso-8859-1" ] 93; 94 95value nl () = Wserver.wprint "\013\010"; 96 97value header_no_page_title conf title = 98 do { 99 Wserver.http ""; 100 Wserver.wprint "Content-type: text/html; charset=%s" (charset conf); 101 nl (); nl (); 102 Wserver.wprint "\ 103<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \ 104\"http://www.w3.org/TR/REC-html40/loose.dtd\"> 105"; 106 Wserver.wprint "<head>\n"; 107 Wserver.wprint " <meta name=\"robots\" content=\"none\">\n"; 108 Wserver.wprint " <title>"; 109 title True; 110 Wserver.wprint "</title>\n"; 111 Wserver.wprint "</head>\n"; 112 Wserver.wprint "<body>\n" 113 } 114; 115 116value abs_setup_dir () = 117 if Filename.is_relative setup_dir.val then 118 Filename.concat (Sys.getcwd ()) setup_dir.val 119 else setup_dir.val 120; 121 122value trailer conf = 123 do { 124 Wserver.wprint "\n<br />\n"; 125 Wserver.wprint "<div id=\"footer\">\n" ; 126 Wserver.wprint "<hr />\n"; 127 Wserver.wprint "<div>\n"; 128 Wserver.wprint "<em>\n"; 129 Wserver.wprint "<a href=\"https://github.com/geneweb/geneweb/\"><img src=\"images/logo_bas.png\" align=\"absmiddle\" style = \"border: 0\" /></a> Version %s Copyright © 1998-2016\n</em>\n" Version.txt; 130 Wserver.wprint "</div>\n" ; 131 Wserver.wprint "</div>\n" ; 132 (* finish the html page *) 133 Wserver.wprint "</body>\n"; 134 Wserver.wprint "</html>\n"; 135 } 136; 137 138value header conf title = 139 do { 140 header_no_page_title conf title; 141 Wserver.wprint "<h1>"; 142 title False; 143 Wserver.wprint "</h1>\n"; 144 } 145; 146 147value strip_control_m s = 148 loop 0 0 where rec loop i len = 149 if i = String.length s then Buff.get len 150 else if s.[i] = '\r' then loop (i + 1) len 151 else loop (i + 1) (Buff.store len s.[i]) 152; 153 154value strip_spaces str = 155 let start = 156 loop 0 where rec loop i = 157 if i = String.length str then i 158 else 159 match str.[i] with 160 [ ' ' | '\r' | '\n' | '\t' -> loop (i + 1) 161 | _ -> i ] 162 in 163 let stop = 164 loop (String.length str - 1) where rec loop i = 165 if i = -1 then i + 1 166 else 167 match str.[i] with 168 [ ' ' | '\r' | '\n' | '\t' -> loop (i - 1) 169 | _ -> i + 1 ] 170 in 171 if start = 0 && stop = String.length str then str 172 else if start > stop then "" 173 else String.sub str start (stop - start) 174; 175 176value code_varenv = Wserver.encode; 177value decode_varenv = Wserver.decode; 178 179value getenv env label = decode_varenv (List.assoc (decode_varenv label) env); 180 181value p_getenv env label = 182 try Some (getenv env label) with [ Not_found -> None ] 183; 184 185value s_getenv env label = try getenv env label with [ Not_found -> "" ]; 186 187value rec skip_spaces s i = 188 if i < String.length s && s.[i] = ' ' then skip_spaces s (i + 1) else i 189; 190 191value create_env s = 192 let rec get_assoc beg i = 193 if i = String.length s then 194 if i = beg then [] else [String.sub s beg (i - beg)] 195 else if s.[i] = ';' || s.[i] = '&' then 196 let next_i = skip_spaces s (succ i) in 197 [String.sub s beg (i - beg) :: get_assoc next_i next_i] 198 else get_assoc beg (succ i) 199 in 200 let rec separate i s = 201 if i = String.length s then (s, "") 202 else if s.[i] = '=' then 203 (String.sub s 0 i, String.sub s (succ i) (String.length s - succ i)) 204 else separate (succ i) s 205 in 206 List.map (separate 0) (get_assoc 0 0) 207; 208 209value numbered_key k = 210 if k = "" then None 211 else 212 match k.[String.length k - 1] with 213 [ '1'..'9' as c -> Some (String.sub k 0 (String.length k - 1), c) 214 | _ -> None ] 215; 216 217value stringify s = 218 try let _ = String.index s ' ' in "\"" ^ s ^ "\"" with [ Not_found -> s ] 219; 220 221value parameters = 222 loop "" where rec loop comm = 223 fun 224 [ [(k, s) :: env] -> 225 let k = strip_spaces (decode_varenv k) in 226 let s = strip_spaces (decode_varenv s) in 227 if k = "" || s = "" then loop comm env 228 else if k = "opt" then loop comm env 229 else if k = "anon" then loop (comm ^ " " ^ stringify s) env 230 else 231 match numbered_key k with 232 [ Some (k, '1') -> 233 let (s, env) = 234 loop ("\"" ^ s ^ "\"") env where rec loop s = 235 fun 236 [ [(k1, s1) :: env] as genv -> 237 match numbered_key k1 with 238 [ Some (k1, _) when k1 = k -> 239 let s1 = strip_spaces (decode_varenv s1) in 240 let s = 241 if s1 = "" then s else s ^ " \"" ^ s1 ^ "\"" 242 in 243 loop s env 244 | _ -> (s, genv) ] 245 | [] -> (s, []) ] 246 in 247 loop (comm ^ " -" ^ k ^ " " ^ s) env 248 | Some _ -> loop comm env 249 | None -> 250 if s = "none" then loop comm env 251 else if s = "on" then loop (comm ^ " -" ^ k) env 252 else if s.[0] = '_' then loop (comm ^ " -" ^ k ^ stringify s) env 253 else if s.[String.length s - 1] = '_' then 254 loop (comm ^ " -" ^ s ^ k) env 255 else loop (comm ^ " -" ^ k ^ " " ^ stringify s) env ] 256 | [] -> comm ] 257; 258 259value rec list_replace k v = 260 fun 261 [ [] -> [(k, v)] 262 | [(k1, v1) :: env] when k1 = k -> [(k1, v) :: env] 263 | [kv :: env] -> [kv :: list_replace k v env] ] 264; 265 266value conf_with_env conf k v = {(conf) with env = list_replace k v conf.env}; 267 268value all_db dir = 269 let list = ref [] in 270 let dh = Unix.opendir dir in 271 do { 272 try 273 while True do { 274 let e = Unix.readdir dh in 275 if Filename.check_suffix e ".gwb" then 276 list.val := [Filename.chop_suffix e ".gwb" :: list.val] 277 else () 278 } 279 with 280 [ End_of_file -> () ]; 281 Unix.closedir dh; 282 list.val := List.sort compare list.val; 283 list.val 284 } 285; 286 287value selected env = 288 List.fold_right (fun (k, v) env -> if v = "on_" then [k :: env] else env) 289 env [] 290; 291 292value parse_upto lim = 293 loop 0 where rec loop len = 294 parser 295 [ [: `c when c = lim :] -> Buff.get len 296 | [: `c; a = loop (Buff.store len c) :] -> a ] 297; 298 299value is_directory x = 300 try (Unix.lstat x).Unix.st_kind = Unix.S_DIR with 301 [ Unix.Unix_error _ _ _ -> False ] 302; 303 304value server_string conf = 305 let s = Wserver.extract_param "host: " '\r' conf.request in 306 try 307 let i = String.rindex s ':' in 308 String.sub s 0 i 309 with 310 [ Not_found -> "127.0.0.1" ] 311; 312 313value referer conf = 314 Wserver.extract_param "referer: " '\r' conf.request 315; 316 317value only_file_name () = 318 if only_file.val = "" then Filename.concat setup_dir.val "only.txt" 319 else only_file.val 320; 321 322value macro conf = 323 fun 324 [ '/' -> IFDEF UNIX THEN "/" ELSE "\\" END 325 | 'a' -> strip_spaces (s_getenv conf.env "anon") 326 | 'c' -> stringify setup_dir.val 327 | 'd' -> conf.comm 328 | 'i' -> strip_spaces (s_getenv conf.env "i") 329 | 'l' -> conf.lang 330 | 'm' -> server_string conf 331 | 'n' -> referer conf 332 | 'o' -> strip_spaces (s_getenv conf.env "o") 333 | 'p' -> parameters conf.env 334 | 'q' -> Version.txt 335 | 'u' -> Filename.dirname (abs_setup_dir ()) 336 | 'x' -> stringify bin_dir.val 337 | 'w' -> slashify (Sys.getcwd ()) 338 | 'y' -> Filename.basename (only_file_name ()) 339 | '%' -> "%" 340 | c -> "BAD MACRO " ^ String.make 1 c ] 341; 342 343value get_variable strm = 344 loop 0 where rec loop len = 345 match strm with parser 346 [ [: `';' :] -> Buff.get len 347 | [: `c :] -> loop (Buff.store len c) ] 348; 349 350value get_binding strm = 351 loop 0 where rec loop len = 352 match strm with parser 353 [ [: `'=' :] -> let k = Buff.get len in (k, get_variable strm) 354 | [: `c :] -> loop (Buff.store len c) ] 355; 356 357value variables bname = 358 let dir = Filename.concat setup_dir.val "setup" in 359 let fname = Filename.concat (Filename.concat dir "lang") bname in 360 let ic = open_in fname in 361 let strm = Stream.of_channel ic in 362 let (vlist, flist) = 363 loop ([], []) where rec loop (vlist, flist) = 364 match strm with parser 365 [ [: `'%' :] -> 366 let (vlist, flist) = 367 match strm with parser 368 [ [: `('E' | 'C') :] -> 369 let (v, _) = get_binding strm in 370 if not (List.mem v vlist) then ([v :: vlist], flist) 371 else (vlist, flist) 372 | [: `'V' :] -> 373 let v = get_variable strm in 374 if not (List.mem v vlist) then ([v :: vlist], flist) 375 else (vlist, flist) 376 | [: `'F' :] -> 377 let v = get_variable strm in 378 if not (List.mem v flist) then (vlist, [v :: flist]) 379 else (vlist, flist) 380 | [: :] -> (vlist, flist) ] 381 in 382 loop (vlist, flist) 383 | [: `_ :] -> loop (vlist, flist) 384 | [: :] -> (vlist, flist) ] 385 in 386 do { 387 close_in ic; 388 (List.rev vlist, flist) 389 } 390; 391 392value nth_field s n = 393 loop 0 0 where rec loop nth i = 394 let j = 395 try String.index_from s i '/' with [ Not_found -> String.length s ] 396 in 397 if nth = n then String.sub s i (j - i) 398 else if j = String.length s then s 399 else loop (nth + 1) (j + 1) 400; 401 402value translate_phrase lang lexicon s n = 403 let n = 404 match n with 405 [ Some n -> n 406 | None -> 0 ] 407 in 408 try 409 let s = Hashtbl.find lexicon s in 410 nth_field s n 411 with 412 [ Not_found -> "[" ^ nth_field s n ^ "]" ] 413; 414 415value rec copy_from_stream conf print strm = 416 try 417 while True do { 418 match Stream.next strm with 419 [ '[' -> 420 match Stream.peek strm with 421 [ Some '\n' -> 422 let s = parse_upto ']' strm in 423 let (s, alt) = Translate.inline conf.lang '%' (macro conf) s in 424 let s = if alt then "[" ^ s ^ "]" else s in 425 print s 426 | _ -> 427 let s = 428 loop 0 where rec loop len = 429 match strm with parser 430 [ [: `']' :] -> Buff.get len 431 | [: `c :] -> loop (Buff.store len c) 432 | [: :] -> Buff.get len ] 433 in 434 let n = 435 match strm with parser 436 [ [: `('0'..'9' as c) :] -> Some (Char.code c - Char.code '0') 437 | [: :] -> None ] 438 in 439 print (translate_phrase conf.lang conf.lexicon s n) ] 440 | '%' -> 441 let c = Stream.next strm in 442 match c with 443 [ 'b' -> for_all conf print (all_db ".") strm 444 | 'e' -> 445 do { 446 print "lang="; 447 print conf.lang; 448 List.iter 449 (fun (k, s) -> 450 if k = "opt" then () 451 else do { print ";"; print k; print "="; print s; () }) 452 conf.env 453 } 454 | 'g' -> print_specific_file conf print "comm.log" strm 455 | 'h' -> 456 do { 457 print "<input type=hidden name=lang value="; 458 print conf.lang; 459 print ">\n"; 460 List.iter 461 (fun (k, s) -> 462 if k = "opt" then () 463 else do { 464 print "<input type=hidden name="; 465 print k; 466 print " value=\""; 467 print (decode_varenv s); 468 print "\">\n"; 469 () 470 }) 471 conf.env 472 } 473 | 'j' -> print_selector conf print 474 | 'k' -> for_all conf print (fst (List.split conf.env)) strm 475 | 'r' -> 476 print_specific_file conf print 477 (Filename.concat setup_dir.val "gwd.arg") strm 478 | 's' -> for_all conf print (selected conf.env) strm 479 | 't' -> 480 print_if conf print (IFDEF UNIX THEN False ELSE True END) strm 481 | 'v' -> 482 let out = strip_spaces (s_getenv conf.env "o") in 483 print_if conf print (Sys.file_exists (out ^ ".gwb")) strm 484 | 'y' -> for_all conf print (all_db (s_getenv conf.env "anon")) strm 485 | 'z' -> print (string_of_int port.val) 486 | 'A'..'Z' | '0'..'9' as c -> 487 match c with 488 [ 'C' | 'E' -> 489 let (k, v) = get_binding strm in 490 match p_getenv conf.env k with 491 [ Some x -> 492 if x = v then 493 print (if c = 'C' then " checked" else " selected") 494 else () 495 | None -> () ] 496 | 'L' -> 497 let lang = get_variable strm in 498 let lang_def = transl conf " !languages" in 499 print (Translate.language_name lang lang_def) 500 | 'V' | 'F' -> 501 let k = get_variable strm in 502 match p_getenv conf.env k with 503 [ Some v -> print v 504 | None -> () ] 505 | _ -> 506 match p_getenv conf.env (String.make 1 c) with 507 [ Some v -> 508 match strm with parser 509 [ [: `'{' :] -> 510 let s = parse_upto '}' strm in 511 do { 512 print "\""; 513 print s; 514 print "\""; 515 if v = s then print " selected" else () 516 } 517 | [: `'[' :] -> 518 let s = parse_upto ']' strm in 519 do { 520 print "\""; 521 print s; 522 print "\""; 523 if v = s then print " checked" else () 524 } 525 | [: :] -> print (strip_spaces v) ] 526 | None -> print "BAD MACRO" ] ] 527 | c -> print (macro conf c) ] 528 | c -> print (String.make 1 c) ] 529 } 530 with 531 [ Stream.Failure -> () ] 532and print_specific_file conf print fname strm = 533 match Stream.next strm with 534 [ '{' -> 535 let s = parse_upto '}' strm in 536 if Sys.file_exists fname then do { 537 let ic = open_in fname in 538 if in_channel_length ic = 0 then 539 copy_from_stream conf print (Stream.of_string s) 540 else copy_from_stream conf print (Stream.of_channel ic); 541 close_in ic 542 } 543 else copy_from_stream conf print (Stream.of_string s) 544 | _ -> () ] 545and print_selector conf print = 546 let sel = 547 try getenv conf.env "sel" with 548 [ Not_found -> 549 try Sys.getenv "HOME" with 550 [ Not_found -> Sys.getcwd () ] ] 551 in 552 let list = 553 let sel = 554 IFDEF WIN95 THEN 555 if String.length sel = 3 && sel.[1] = ':' && sel.[2] = '\\' then 556 sel ^ "." 557 else sel 558 ELSE sel END 559 in 560 try 561 let dh = Unix.opendir sel in 562 loop [] where rec loop list = 563 match try Some (Unix.readdir dh) with [ End_of_file -> None ] with 564 [ Some x -> 565 let list = 566 if x = ".." then [x :: list] 567 else if String.length x > 0 && x.[0] = '.' then list 568 else [x :: list] 569 in 570 loop list 571 | None -> List.sort compare list ] 572 with 573 [ Unix.Unix_error _ _ _ -> [".."] ] 574 in 575 do { 576 print "<pre>\n"; 577 print " "; 578 print "<input type=hidden name=anon value=\""; 579 print sel; 580 print "\">"; 581 print sel; 582 print "</a>\n"; 583 let list = 584 List.map 585 (fun x -> 586 let d = 587 if x = ".." then 588 IFDEF WIN95 THEN 589 if sel.[String.length sel - 1] <> '\\' then 590 Filename.dirname sel ^ "\\" 591 else Filename.dirname sel 592 ELSE Filename.dirname sel END 593 else Filename.concat sel x 594 in 595 let x = if is_directory d then Filename.concat x "" else x in 596 (d, x)) 597 list 598 in 599 let max_len = 600 List.fold_left (fun max_len (_, x) -> max max_len (String.length x)) 601 0 list 602 in 603 let min_interv = 2 in 604 let line_len = 72 in 605 let n_by_line = max 1 ((line_len + min_interv) / (max_len + min_interv)) in 606 let newline () = print "\n " in 607 newline (); 608 loop 1 list where rec loop i = 609 fun 610 [ [(d, x) :: list] -> 611 do { 612 print "<a href=\""; 613 print conf.comm; 614 print "?lang="; 615 print conf.lang; 616 print ";"; 617 List.iter 618 (fun (k, v) -> 619 if k = "sel" then () 620 else do { print k; print "="; print v; print ";" }) 621 conf.env; 622 print "sel="; 623 print (code_varenv d); 624 print "\">"; 625 print x; 626 print "</a>"; 627 if i = n_by_line then do { 628 newline (); 629 loop 1 list; 630 } 631 else if list = [] then newline () 632 else do { 633 print (String.make (max_len + 2 - String.length x) ' '); 634 loop (i + 1) list 635 } 636 } 637 | [] -> print "\n" ]; 638 print "</pre>\n"; 639 } 640and print_if conf print cond strm = 641 match Stream.next strm with 642 [ '{' -> 643 let s = parse_upto '}' strm in 644 if cond then copy_from_stream conf print (Stream.of_string s) else () 645 | _ -> () ] 646and for_all conf print list strm = 647 match Stream.next strm with 648 [ '{' -> 649 let s_exist = parse_upto '|' strm in 650 let s_empty = parse_upto '}' strm in 651 let eol = 652 match strm with parser [ [: `'\\' :] -> False | [: :] -> True ] 653 in 654 if list <> [] then 655 List.iter 656 (fun db -> 657 let conf = conf_with_env conf "anon" db in 658 do { 659 copy_from_stream conf print (Stream.of_string s_exist); 660 if eol then print "\n" else () 661 }) 662 list 663 else do { 664 copy_from_stream conf print (Stream.of_string s_empty); 665 if eol then print "\n" else () 666 } 667 | _ -> () ] 668; 669 670value print_file conf bname = 671 let dir = Filename.concat setup_dir.val "setup" in 672 let fname = Filename.concat (Filename.concat dir "lang") bname in 673 let ic_opt = 674 try Some (open_in fname) with 675 [ Sys_error _ -> None ] 676 in 677 match ic_opt with 678 [ Some ic -> 679 do { 680 Wserver.http ""; 681 Wserver.wprint "Content-type: text/html; charset=%s" (charset conf); 682 nl (); nl (); 683 copy_from_stream conf (fun x -> Wserver.wprint "%s" x) 684 (Stream.of_channel ic); 685 close_in ic; 686 trailer conf 687 } 688 | None -> 689 let title _ = Wserver.wprint "Error" in 690 do { 691 header conf title; 692 Wserver.wprint "<ul><li>\n"; 693 Wserver.wprint "Cannot access file \"%s\".\n" fname; 694 Wserver.wprint "</ul>\n"; 695 trailer conf; 696 raise Exit 697 } ] 698; 699 700value error conf str = 701 do { 702 header conf (fun _ -> Wserver.wprint "Incorrect request"); 703 Wserver.wprint "<em>%s</em>\n" (String.capitalize str); 704 trailer conf 705 } 706; 707 708value exec_f comm = 709 let s = comm ^ " > " ^ "comm.log" in 710 do { 711 eprintf "$ cd \"%s\"\n" (Sys.getcwd ()); 712 flush stderr; 713 eprintf "$ %s\n" s; 714 flush stderr; 715 Sys.command s 716 } 717; 718 719value good_name s = 720 loop 0 where rec loop i = 721 if i = String.length s then True 722 else 723 match s.[i] with 724 [ 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' -> loop (i + 1) 725 | _ -> False ] 726; 727 728value out_name_of_ged in_file = 729 let f = Filename.basename in_file in 730 if Filename.check_suffix f ".ged" then Filename.chop_suffix f ".ged" 731 else if Filename.check_suffix f ".GED" then Filename.chop_suffix f ".GED" 732 else f 733; 734 735value out_name_of_gw in_file = 736 let f = Filename.basename in_file in 737 if Filename.check_suffix f ".gw" then Filename.chop_suffix f ".gw" 738 else if Filename.check_suffix f ".GW" then Filename.chop_suffix f ".GW" 739 else f 740; 741 742value basename s = 743 loop (String.length s - 1) where rec loop i = 744 if i < 0 then s 745 else 746 match s.[i] with 747 [ 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' | '.' -> loop (i - 1) 748 | _ -> String.sub s (i + 1) (String.length s - i - 1) ] 749; 750 751value setup_gen conf = 752 match p_getenv conf.env "v" with 753 [ Some fname -> print_file conf (basename fname) 754 | _ -> error conf "request needs \"v\" parameter" ] 755; 756 757value print_default_gwf_file conf = 758 let gwf = 759 [ "access_by_key=yes"; 760 "disable_forum=yes"; 761 "hide_private_names=no"; 762 "use_restrict=no"; 763 "show_consang=yes"; 764 "display_sosa=yes"; 765 "place_surname_link_to_ind=yes"; 766 "max_anc_level=8"; 767 "max_anc_tree=7"; 768 "max_desc_level=12"; 769 "max_desc_tree=4"; 770 "max_cousins=2000"; 771 "max_cousins_level=5"; 772 "latest_event=20"; 773 "template=*"; 774 "long_date=no"; 775 "counter=no"; 776 "full_siblings=yes"; 777 "hide_advanced_request=no" ] 778 in 779 let bname = try List.assoc "o" conf.env with [ Not_found -> "" ] in 780 let dir = Sys.getcwd () in 781 let fname = Filename.concat dir (bname ^ ".gwf") in 782 if Sys.file_exists fname then () 783 else do { 784 let oc = open_out fname in 785 List.iter (fun s -> fprintf oc "%s\n" s) gwf; 786 close_out oc 787 } 788; 789 790value simple conf = 791 let ged = 792 match p_getenv conf.env "anon" with 793 [ Some f -> strip_spaces f 794 | None -> "" ] 795 in 796 let ged = 797 if Filename.check_suffix (String.lowercase ged) ".ged" then ged 798 else "" 799 in 800 let out_file = 801 match p_getenv conf.env "o" with 802 [ Some f -> strip_spaces f 803 | _ -> "" ] 804 in 805 let out_file = 806 if ged = "" then out_file 807 else if out_file = "" then out_name_of_ged ged 808 else out_file 809 in 810 let env = [("f", "on") :: conf.env] in 811 let env = list_replace "anon" ged env in 812 let conf = 813 {comm = if ged = "" then "gwc" else "ged2gwb"; 814 env = list_replace "o" out_file env; lang = conf.lang; 815 request = conf.request; lexicon = conf.lexicon} 816 in 817 if ged <> "" && not (Sys.file_exists ged) then 818 print_file conf "err_unkn.htm" 819 else if out_file = "" then print_file conf "err_miss.htm" 820 else if not (good_name out_file) then print_file conf "err_name.htm" 821 else print_file conf "bso.htm" 822; 823 824value simple2 conf = 825 let ged = 826 match p_getenv conf.env "anon" with 827 [ Some f -> strip_spaces f 828 | None -> "" ] 829 in 830 let ged = 831 if Filename.check_suffix (String.lowercase ged) ".ged" then ged 832 else "" 833 in 834 let out_file = 835 match p_getenv conf.env "o" with 836 [ Some f -> strip_spaces f 837 | _ -> "" ] 838 in 839 let out_file = 840 if ged = "" then out_file 841 else if out_file = "" then out_name_of_ged ged 842 else out_file 843 in 844 let env = [("f", "on") :: conf.env] in 845 let env = list_replace "anon" ged env in 846 let conf = 847 {comm = if ged = "" then "gwc2" else "ged2gwb2"; 848 env = list_replace "o" out_file env; lang = conf.lang; 849 request = conf.request; lexicon = conf.lexicon} 850 in 851 if ged <> "" && not (Sys.file_exists ged) then 852 print_file conf "err_unkn.htm" 853 else if out_file = "" then print_file conf "err_miss.htm" 854 else if not (good_name out_file) then print_file conf "err_name.htm" 855 else print_file conf "bso.htm" 856; 857 858value gwc_or_ged2gwb out_name_of_in_name conf = 859 let in_file = 860 match p_getenv conf.env "anon" with 861 [ Some f -> strip_spaces f 862 | None -> "" ] 863 in 864 let out_file = 865 match p_getenv conf.env "o" with 866 [ Some f -> strip_spaces f 867 | _ -> "" ] 868 in 869 let out_file = 870 if out_file = "" then out_name_of_in_name in_file else out_file 871 in 872 let conf = conf_with_env conf "o" out_file in 873 if in_file = "" || out_file = "" then print_file conf "err_miss.htm" 874 else if not (Sys.file_exists in_file) then print_file conf "err_unkn.htm" 875 else if not (good_name out_file) then print_file conf "err_name.htm" 876 else print_file conf "bso.htm" 877; 878 879value gwc2_or_ged2gwb2 out_name_of_in_name conf = 880 let in_file = 881 match p_getenv conf.env "anon" with 882 [ Some f -> strip_spaces f 883 | None -> "" ] 884 in 885 let out_file = 886 match p_getenv conf.env "o" with 887 [ Some f -> strip_spaces f 888 | _ -> "" ] 889 in 890 let out_file = 891 if out_file = "" then out_name_of_in_name in_file else out_file 892 in 893 let conf = conf_with_env conf "o" out_file in 894 if in_file = "" || out_file = "" then print_file conf "err_miss.htm" 895 else if not (Sys.file_exists in_file) then print_file conf "err_unkn.htm" 896 else if not (good_name out_file) then print_file conf "err_name.htm" 897 else print_file conf "bso.htm" 898; 899 900value gwc_check conf = 901 let conf = {(conf) with env = [("nofail", "on"); ("f", "on") :: conf.env]} in 902 gwc_or_ged2gwb out_name_of_gw conf 903; 904 905value gwc2_check conf = 906 let conf = {(conf) with env = [("nofail", "on"); ("f", "on") :: conf.env]} in 907 gwc2_or_ged2gwb2 out_name_of_gw conf 908; 909 910value ged2gwb_check conf = 911 let conf = {(conf) with env = [("f", "on") :: conf.env]} in 912 gwc_or_ged2gwb out_name_of_ged conf 913; 914 915value ged2gwb2_check conf = 916 let conf = {(conf) with env = [("f", "on") :: conf.env]} in 917 gwc2_or_ged2gwb2 out_name_of_ged conf 918; 919 920(*ifdef WIN95 then*) 921value infer_rc conf rc = 922 if rc > 0 then rc 923 else 924 match p_getenv conf.env "o" with 925 [ Some out_file -> 926 if Sys.file_exists (out_file ^ ".gwb") then 0 else 2 927 | _ -> 0 ] 928; 929 930value gwc conf = 931 let rc = 932 let comm = stringify (Filename.concat bin_dir.val "gwc") in 933 exec_f (comm ^ parameters conf.env) 934 in 935 let rc = IFDEF WIN95 THEN infer_rc conf rc ELSE rc END in 936 do { 937 let gwo = strip_spaces (s_getenv conf.env "anon") ^ "o" in 938 try Sys.remove gwo with [ Sys_error _ -> () ]; 939 eprintf "\n"; 940 flush stderr; 941 if rc > 1 then print_file conf "bso_err.htm" 942 else do { 943 print_default_gwf_file conf; 944 print_file conf "bso_ok.htm" 945 } 946 } 947; 948 949value gwc2 conf = 950 let rc = 951 let comm = stringify (Filename.concat bin_dir.val "gwc2") in 952 exec_f (comm ^ parameters conf.env) 953 in 954 let rc = IFDEF WIN95 THEN infer_rc conf rc ELSE rc END in 955 do { 956 let gwo = strip_spaces (s_getenv conf.env "anon") ^ "o" in 957 try Sys.remove gwo with [ Sys_error _ -> () ]; 958 eprintf "\n"; 959 flush stderr; 960 if rc > 1 then print_file conf "bso_err.htm" 961 else do { 962 print_default_gwf_file conf; 963 print_file conf "bso_ok.htm" 964 } 965 } 966; 967 968value gwu_or_gwb2ged_check suffix conf = 969 let in_file = 970 match p_getenv conf.env "anon" with 971 [ Some f -> strip_spaces f 972 | None -> "" ] 973 in 974 let out_file = 975 match p_getenv conf.env "o" with 976 [ Some f -> Filename.basename (strip_spaces f) 977 | None -> "" ] 978 in 979 let out_file = 980 if out_file = "" || out_file = Filename.current_dir_name then 981 in_file ^ suffix 982 else if Filename.check_suffix out_file suffix then out_file 983 else if Filename.check_suffix out_file (String.uppercase suffix) then 984 out_file 985 else out_file ^ suffix 986 in 987 let conf = conf_with_env conf "o" out_file in 988 if in_file = "" then print_file conf "err_miss.htm" 989 else print_file conf "bsi.htm" 990; 991 992value gwu = gwu_or_gwb2ged_check ".gw"; 993value gwb2ged = gwu_or_gwb2ged_check ".ged"; 994 995value gwb2ged_or_gwu_1 ok_file conf = 996 let rc = 997 let comm = stringify (Filename.concat bin_dir.val conf.comm) in 998 exec_f (comm ^ parameters conf.env) 999 in 1000 do { 1001 eprintf "\n"; 1002 flush stderr; 1003 if rc > 1 then print_file conf "bsi_err.htm" 1004 else 1005 let conf = 1006 conf_with_env conf "o" (Filename.basename (s_getenv conf.env "o")) 1007 in 1008 print_file conf ok_file 1009 } 1010; 1011 1012value gwb2ged_1 = gwb2ged_or_gwu_1 "gw2gd_ok.htm"; 1013value gwu_1 = gwb2ged_or_gwu_1 "gwu_ok.htm"; 1014 1015value consang_check conf = 1016 let in_f = 1017 match p_getenv conf.env "anon" with 1018 [ Some f -> strip_spaces f 1019 | None -> "" ] 1020 in 1021 if in_f = "" then print_file conf "err_miss.htm" 1022 else print_file conf "bsi.htm" 1023; 1024 1025value update_nldb_check conf = 1026 let in_f = 1027 match p_getenv conf.env "anon" with 1028 [ Some f -> strip_spaces f 1029 | None -> "" ] 1030 in 1031 if in_f = "" then print_file conf "err_miss.htm" 1032 else print_file conf "bsi.htm" 1033; 1034 1035value has_gwu dir = 1036 match 1037 try Some (Unix.opendir dir) with [ Unix.Unix_error _ _ _ -> None ] 1038 with 1039 [ Some dh -> 1040 let gwu_found = 1041 try 1042 loop () where rec loop () = 1043 let e = Unix.readdir dh in 1044 IFDEF UNIX THEN 1045 match e with 1046 [ "gwu" -> raise Exit 1047 | _ -> loop () ] 1048 ELSE 1049 match String.lowercase e with 1050 [ "gwu.exe" -> raise Exit 1051 | _ -> loop () ] 1052 END 1053 with 1054 [ End_of_file -> False 1055 | Exit -> True ] 1056 in 1057 do { Unix.closedir dh; gwu_found } 1058 | None -> False ] 1059; 1060 1061value recover conf = 1062 let init_dir = 1063 match p_getenv conf.env "anon" with 1064 [ Some f -> strip_spaces f 1065 | None -> "" ] 1066 in 1067 let (init_dir, dir_has_gwu) = 1068 if has_gwu init_dir then (init_dir, True) 1069 else 1070 let dir = init_dir in 1071 if has_gwu dir then (dir, True) 1072 else 1073 let dir = Filename.dirname init_dir in 1074 if has_gwu dir then (dir, True) 1075 else 1076 let dir = Filename.concat dir "gw" in 1077 if has_gwu dir then (dir, True) else (init_dir, False) 1078 in 1079 let conf = conf_with_env conf "anon" init_dir in 1080 let dest_dir = Sys.getcwd () in 1081 if init_dir = "" then print_file conf "err_miss.htm" 1082 else if init_dir = dest_dir then print_file conf "err_smdr.htm" 1083 else if not (Sys.file_exists init_dir) then print_file conf "err_ndir.htm" 1084 else if 1085 (IFDEF UNIX THEN 1086 try 1087 (Unix.stat (Filename.concat init_dir ".")).Unix.st_ino = 1088 (Unix.stat (Filename.concat dest_dir ".")).Unix.st_ino 1089 with 1090 [ Unix.Unix_error _ _ _ -> False ] 1091 ELSE False END) 1092 then 1093 print_file conf "err_smdr.htm" 1094 else if not dir_has_gwu then print_file conf "err_ngw.htm" 1095 else print_file conf "recover1.htm" 1096; 1097 1098value recover_1 conf = 1099 let in_file = 1100 match p_getenv conf.env "i" with 1101 [ Some f -> strip_spaces f 1102 | None -> "" ] 1103 in 1104 let out_file = 1105 match p_getenv conf.env "o" with 1106 [ Some f -> strip_spaces f 1107 | None -> "" ] 1108 in 1109 let by_gedcom = 1110 match p_getenv conf.env "ged" with 1111 [ Some "on" -> True 1112 | _ -> False ] 1113 in 1114 let out_file = if out_file = "" then in_file else out_file in 1115 let conf = conf_with_env conf "o" out_file in 1116 if in_file = "" then print_file conf "err_miss.htm" 1117 else if not (good_name out_file) then print_file conf "err_name.htm" 1118 else 1119 let (old_to_src, o_opt, tmp, src_to_new) = 1120 if not by_gedcom then ("gwu", " > ", "tmp.gw", "gwc") 1121 else ("gwb2ged", " -o ", "tmp.ged", "ged2gwb") 1122 in 1123 let conf = 1124 {(conf) with 1125 env = 1126 [("U", old_to_src); ("O", o_opt); ("T", tmp); 1127 ("src2new", src_to_new) :: conf.env]} 1128 in 1129 print_file conf "recover2.htm" 1130; 1131 1132value recover_2 conf = 1133 let init_dir = 1134 match p_getenv conf.env "anon" with 1135 [ Some f -> strip_spaces f 1136 | None -> "" ] 1137 in 1138 let in_file = 1139 match p_getenv conf.env "i" with 1140 [ Some f -> strip_spaces f 1141 | None -> "" ] 1142 in 1143 let out_file = 1144 match p_getenv conf.env "o" with 1145 [ Some f -> strip_spaces f 1146 | None -> "" ] 1147 in 1148 let by_gedcom = 1149 match p_getenv conf.env "ged" with 1150 [ Some "on" -> True 1151 | _ -> False ] 1152 in 1153 let (old_to_src, o_opt, tmp, src_to_new) = 1154 if not by_gedcom then ("gwu", " > ", "tmp.gw", "gwc") 1155 else ("gwb2ged", " -o ", "tmp.ged", "ged2gwb") 1156 in 1157 let out_file = if out_file = "" then in_file else out_file in 1158 let conf = conf_with_env conf "o" out_file in 1159 let dir = Sys.getcwd () in 1160 let rc = 1161 try 1162 do { 1163 eprintf "$ cd \"%s\"\n" init_dir; 1164 flush stderr; 1165 Sys.chdir init_dir; 1166 let c = 1167 Filename.concat "." old_to_src ^ " " ^ in_file ^ o_opt ^ 1168 stringify (Filename.concat dir tmp) 1169 in 1170 eprintf "$ %s\n" c; 1171 flush stderr; 1172 Sys.command c 1173 } 1174 with e -> 1175 do { Sys.chdir dir; raise e } 1176 in 1177 let rc = 1178 if rc = 0 then do { 1179 eprintf "$ cd \"%s\"\n" dir; 1180 flush stderr; 1181 Sys.chdir dir; 1182 let c = 1183 Filename.concat bin_dir.val src_to_new ^ " " ^ tmp ^ " -f -o " ^ 1184 out_file ^ " > " ^ "comm.log" 1185 in 1186 eprintf "$ %s\n" c; 1187 flush stderr; 1188 let rc = Sys.command c in 1189 let rc = IFDEF WIN95 THEN infer_rc conf rc ELSE rc END in 1190 eprintf "\n"; 1191 flush stderr; 1192 rc 1193 } 1194 else rc 1195 in 1196 do { 1197 if rc > 1 then do { Sys.chdir dir; print_file conf "err_reco.htm" } 1198 else print_file conf "bso_ok.htm" 1199 } 1200; 1201 1202value rmdir dir = 1203 (* Récupère tous les fichiers et dossier d'un dossier *) 1204 (* et renvoie la liste des dossiers et la liste des fichiers. *) 1205 let read_files_folders fname = 1206 let list = 1207 List.map 1208 (fun file -> Filename.concat fname file) 1209 (Array.to_list (Sys.readdir fname)) 1210 in 1211 List.partition Sys.is_directory list 1212 in 1213 (* Parcours récursif de tous les dossiers *) 1214 let rec loop l folders files = 1215 match l with 1216 [ [] -> (folders, files) 1217 | [x :: l] -> 1218 let (fd, fi) = read_files_folders x in 1219 let l = List.rev_append l fd in 1220 let folders = List.rev_append fd folders in 1221 let files = List.rev_append fi files in 1222 loop l folders files ] 1223 in 1224 (* Toute l'arborescence de dir *) 1225 let (folders, files) = loop [dir] [] [] in 1226 do { 1227 List.iter (fun f -> try Unix.unlink f with [ _ -> () ]) files; 1228 List.iter (fun f -> try Unix.rmdir f with [ _ -> () ]) folders; 1229 try Unix.rmdir dir with [ Unix.Unix_error _ _ _ -> () ] 1230 } 1231; 1232 1233value rm_base dir = rmdir dir; 1234 1235value cleanup conf = 1236 let in_base = 1237 match p_getenv conf.env "anon" with 1238 [ Some f -> strip_spaces f 1239 | None -> "" ] 1240 in 1241 let conf = {(conf) with comm = "."} in 1242 if in_base = "" then print_file conf "err_miss.htm" 1243 else print_file conf "cleanup1.htm" 1244; 1245 1246value cleanup_1 conf = 1247 let in_base = 1248 match p_getenv conf.env "anon" with 1249 [ Some f -> strip_spaces f 1250 | None -> "" ] 1251 in 1252 let in_base_dir = in_base ^ ".gwb" in 1253 do { 1254 eprintf "$ cd \"%s\"\n" (Sys.getcwd ()); 1255 flush stderr; 1256 let c = 1257 Filename.concat bin_dir.val "gwu" ^ " " ^ in_base ^ " -o tmp.gw" 1258 in 1259 eprintf "$ %s\n" c; 1260 flush stderr; 1261 let _ = Sys.command c in 1262 eprintf "$ mkdir old\n"; 1263 try Unix.mkdir "old" 0o755 with [ Unix.Unix_error _ _ _ -> () ]; 1264 IFDEF UNIX THEN eprintf "$ rm -rf old/%s\n" in_base_dir 1265 ELSE do { 1266 eprintf "$ del old\\%s\\*.*\n" in_base_dir; 1267 eprintf "$ rmdir old\\%s\n" in_base_dir 1268 } END; 1269 flush stderr; 1270 rm_base (Filename.concat "old" in_base_dir); 1271 IFDEF UNIX THEN eprintf "$ mv %s old/.\n" in_base_dir 1272 ELSE eprintf "$ move %s old\\.\n" in_base_dir END; 1273 flush stderr; 1274 Sys.rename in_base_dir (Filename.concat "old" in_base_dir); 1275 let c = 1276 Filename.concat bin_dir.val "gwc" ^ " tmp.gw -nofail -o " ^ in_base ^ 1277 " > comm.log 2>&1" 1278 in 1279 eprintf "$ %s\n" c; 1280 flush stderr; 1281 let rc = Sys.command c in 1282 let rc = IFDEF WIN95 THEN infer_rc conf rc ELSE rc END in 1283 eprintf "\n"; 1284 flush stderr; 1285 if rc > 1 then 1286 let conf = {(conf) with comm = "gwc"} in 1287 print_file conf "bsi_err.htm" 1288 else print_file conf "clean_ok.htm" 1289 } 1290; 1291 1292value rec check_new_names conf l1 l2 = 1293 match (l1, l2) with 1294 [ ([(k, v) :: l], [x :: m]) -> 1295 if k <> x then do { print_file conf "err_outd.htm"; raise Exit } 1296 else if not (good_name v) then do { 1297 let conf = {(conf) with env = [("o", v) :: conf.env]} in 1298 print_file conf "err_name.htm"; 1299 raise Exit 1300 } 1301 else check_new_names conf l m 1302 | ([], []) -> () 1303 | _ -> do { print_file conf "err_outd.htm"; raise Exit } ] 1304; 1305 1306value rec check_rename_conflict conf = 1307 fun 1308 [ [x :: l] -> 1309 if List.mem x l then do { 1310 let conf = {(conf) with env = [("o", x) :: conf.env]} in 1311 print_file conf "err_cnfl.htm"; 1312 raise Exit 1313 } 1314 else check_rename_conflict conf l 1315 | [] -> () ] 1316; 1317 1318value rename conf = 1319 let rename_list = 1320 List.map (fun (k, v) -> (k, strip_spaces (decode_varenv v))) conf.env 1321 in 1322 try 1323 do { 1324 check_new_names conf rename_list (all_db "."); 1325 check_rename_conflict conf (snd (List.split rename_list)); 1326 List.iter 1327 (fun (k, v) -> 1328 if k <> v then Sys.rename (k ^ ".gwb") ("_" ^ k ^ ".gwb") else ()) 1329 rename_list; 1330 List.iter 1331 (fun (k, v) -> 1332 if k <> v then Sys.rename ("_" ^ k ^ ".gwb") (v ^ ".gwb") else ()) 1333 rename_list; 1334 print_file conf "ren_ok.htm" 1335 } 1336 with 1337 [ Exit -> () ] 1338; 1339 1340value delete conf = print_file conf "delete_1.htm"; 1341 1342value delete_1 conf = 1343 do { 1344 List.iter (fun (k, v) -> if v = "del" then rm_base (k ^ ".gwb") else ()) 1345 conf.env; 1346 print_file conf "del_ok.htm" 1347 } 1348; 1349 1350value merge conf = 1351 let out_file = 1352 match p_getenv conf.env "o" with 1353 [ Some f -> strip_spaces f 1354 | _ -> "" ] 1355 in 1356 let conf = {(conf) with comm = "."} in 1357 let bases = selected conf.env in 1358 if out_file = "" || List.length bases < 2 then 1359 print_file conf "err_miss.htm" 1360 else if not (good_name out_file) then print_file conf "err_name.htm" 1361 else print_file conf "merge_1.htm" 1362; 1363 1364value merge_1 conf = 1365 let out_file = 1366 match p_getenv conf.env "o" with 1367 [ Some f -> strip_spaces f 1368 | _ -> "" ] 1369 in 1370 let bases = selected conf.env in 1371 let dir = Sys.getcwd () in 1372 do { 1373 eprintf "$ cd \"%s\"\n" dir; 1374 flush stderr; 1375 Sys.chdir dir; 1376 let rc = 1377 loop bases where rec loop = 1378 fun 1379 [ [] -> 0 1380 | [b :: bases] -> 1381 let c = 1382 Filename.concat bin_dir.val "gwu" ^ " " ^ b ^ " -o " ^ b ^ 1383 ".gw" 1384 in 1385 do { 1386 eprintf "$ %s\n" c; 1387 flush stderr; 1388 let r = Sys.command c in 1389 if r = 0 then loop bases else r 1390 } ] 1391 in 1392 let rc = 1393 if rc <> 0 then rc 1394 else do { 1395 let c = 1396 Filename.concat bin_dir.val "gwc" ^ 1397 List.fold_left 1398 (fun s b -> 1399 if s = "" then " " ^ b ^ ".gw" else s ^ " -sep " ^ b ^ ".gw") 1400 "" bases ^ 1401 " -f -o " ^ out_file ^ " > comm.log 2>&1" 1402 in 1403 eprintf "$ %s\n" c; 1404 flush stderr; 1405 Sys.command c 1406 } 1407 in 1408 if rc > 1 then print_file conf "bso_err.htm" 1409 else print_file conf "bso_ok.htm" 1410 } 1411; 1412 1413value rec cut_at_equal s = 1414 try 1415 let i = String.index s '=' in 1416 (String.sub s 0 i, String.sub s (succ i) (String.length s - succ i)) 1417 with 1418 [ Not_found -> (s, "") ] 1419; 1420 1421value read_base_env bname = 1422 let fname = bname ^ ".gwf" in 1423 match try Some (open_in fname) with [ Sys_error _ -> None ] with 1424 [ Some ic -> 1425 let env = 1426 loop [] where rec loop env = 1427 match try Some (input_line ic) with [ End_of_file -> None ] with 1428 [ Some s -> 1429 if s = "" || s.[0] = '#' then loop env 1430 else loop [cut_at_equal s :: env] 1431 | None -> env ] 1432 in 1433 do { close_in ic; env } 1434 | None -> [] ] 1435; 1436 1437value read_gwd_arg () = 1438 let fname = Filename.concat setup_dir.val "gwd.arg" in 1439 match try Some (open_in fname) with [ Sys_error _ -> None ] with 1440 [ Some ic -> 1441 let list = 1442 loop [] where rec loop list = 1443 match try Some (input_line ic) with [ End_of_file -> None ] with 1444 [ Some "" -> loop list 1445 | Some s -> loop [s :: list] 1446 | None -> list ] 1447 in 1448 do { 1449 close_in ic; 1450 let rec loop env = 1451 fun 1452 [ [x :: l] -> 1453 if x.[0] = '-' then 1454 let x = String.sub x 1 (String.length x - 1) in 1455 match l with 1456 [ [y :: l] when y.[0] <> '-' -> loop [(x, y) :: env] l 1457 | _ -> loop [(x, "") :: env] l ] 1458 else loop env l 1459 | [] -> List.rev env ] 1460 in 1461 loop [] (List.rev list) 1462 } 1463 | None -> [] ] 1464; 1465 1466value file_contents fname = 1467 match try Some (open_in fname) with [ Sys_error _ -> None ] with 1468 [ Some ic -> 1469 loop 0 where rec loop len = 1470 match try Some (input_char ic) with [ End_of_file -> None ] with 1471 [ Some '\r' -> loop len 1472 | Some c -> loop (Buff.store len c) 1473 | None -> do { close_in ic; Buff.get len } ] 1474 | None -> "" ] 1475; 1476 1477value gwf conf = 1478 let in_base = 1479 match p_getenv conf.env "anon" with 1480 [ Some f -> strip_spaces f 1481 | None -> "" ] 1482 in 1483 if in_base = "" then print_file conf "err_miss.htm" 1484 else 1485 let benv = read_base_env in_base in 1486 let trailer = 1487 quote_escaped 1488 (file_contents (Filename.concat "lang" (in_base ^ ".trl"))) 1489 in 1490 let conf = 1491 {(conf) with 1492 env = 1493 List.map (fun (k, v) -> (k, quote_escaped v)) benv @ 1494 [("trailer", trailer) :: conf.env]} 1495 in 1496 print_file conf "gwf_1.htm" 1497; 1498 1499value gwf_1 conf = 1500 let in_base = 1501 match p_getenv conf.env "anon" with 1502 [ Some f -> strip_spaces f 1503 | None -> "" ] 1504 in 1505 let benv = read_base_env in_base in 1506 let (vars, files) = variables "gwf_1.htm" in 1507 do { 1508 let oc = open_out (in_base ^ ".gwf") in 1509 let body_prop = 1510 match p_getenv conf.env "proposed_body_prop" with 1511 [ Some "" | None -> s_getenv conf.env "body_prop" 1512 | Some x -> x ] 1513 in 1514 fprintf oc "# File generated by \"setup\"\n\n"; 1515 List.iter 1516 (fun k -> 1517 match k with 1518 [ "body_prop" -> 1519 if body_prop = "" then () 1520 else fprintf oc "body_prop=%s\n" body_prop 1521 | _ -> fprintf oc "%s=%s\n" k (s_getenv conf.env k) ]) 1522 vars; 1523 List.iter 1524 (fun (k, v) -> 1525 if List.mem k vars then () 1526 else fprintf oc "%s=%s\n" k v) 1527 benv; 1528 1529 close_out oc; 1530 let trl = strip_spaces (strip_control_m (s_getenv conf.env "trailer")) in 1531 let trl_file = Filename.concat "lang" (in_base ^ ".trl") in 1532 try Unix.mkdir "lang" 0o755 with [ Unix.Unix_error _ _ _ -> () ]; 1533 try 1534 if trl = "" then Sys.remove trl_file 1535 else do { 1536 let oc = open_out trl_file in 1537 output_string oc trl; 1538 output_string oc "\n"; 1539 close_out oc 1540 } 1541 with 1542 [ Sys_error _ -> () ]; 1543 print_file conf "gwf_ok.htm" 1544 } 1545; 1546 1547value gwd conf = 1548 let aenv = read_gwd_arg () in 1549 let get v = try List.assoc v aenv with [ Not_found -> "" ] in 1550 let conf = 1551 {(conf) with 1552 env = 1553 [("default_lang", get "lang"); ("only", get "only"); 1554 ("log", Filename.basename (get "log")) :: 1555 conf.env]} 1556 in 1557 print_file conf "gwd.htm" 1558; 1559 1560value gwd_1 conf = 1561 let oc = open_out (Filename.concat setup_dir.val "gwd.arg") in 1562 let print_param k = 1563 match p_getenv conf.env k with 1564 [ Some v when v <> "" -> fprintf oc "-%s\n%s\n" k v 1565 | _ -> () ] 1566 in 1567 do { 1568 match p_getenv conf.env "setup_link" with 1569 [ Some v -> fprintf oc "-setup_link\n" 1570 | _ -> () ]; 1571 print_param "only"; 1572 match p_getenv conf.env "default_lang" with 1573 [ Some v when v <> "" -> fprintf oc "-lang\n%s\n" v 1574 | _ -> () ]; 1575 print_param "log"; 1576 close_out oc; 1577 print_file conf "gwd_ok.htm" 1578 } 1579; 1580 1581value ged2gwb conf = 1582 let rc = 1583 let comm = stringify (Filename.concat bin_dir.val conf.comm) in 1584 exec_f (comm ^ " -fne '\"\"'" ^ parameters conf.env) 1585 in 1586 let rc = IFDEF WIN95 THEN infer_rc conf rc ELSE rc END in 1587 do { 1588 eprintf "\n"; 1589 flush stderr; 1590 if rc > 1 then print_file conf "bso_err.htm" 1591 else do { 1592 print_default_gwf_file conf; 1593 print_file conf "bso_ok.htm" 1594 } 1595 } 1596; 1597 1598value ged2gwb2 conf = 1599 let rc = 1600 let comm = stringify (Filename.concat bin_dir.val conf.comm) in 1601 exec_f (comm ^ " -fne '\"\"'" ^ parameters conf.env) 1602 in 1603 let rc = IFDEF WIN95 THEN infer_rc conf rc ELSE rc END in 1604 do { 1605 eprintf "\n"; 1606 flush stderr; 1607 if rc > 1 then print_file conf "bso_err.htm" 1608 else do { 1609 print_default_gwf_file conf; 1610 print_file conf "bso_ok.htm" 1611 } 1612 } 1613; 1614 1615value consang conf ok_file = 1616 let rc = 1617 let comm = stringify (Filename.concat bin_dir.val conf.comm) in 1618 exec_f (comm ^ parameters conf.env) 1619 in 1620 do { 1621 eprintf "\n"; 1622 flush stderr; 1623 if rc > 1 then print_file conf "bsi_err.htm" else print_file conf ok_file 1624 } 1625; 1626 1627value update_nldb conf ok_file = 1628 let rc = 1629 let comm = stringify (Filename.concat bin_dir.val conf.comm) in 1630 exec_f (comm ^ parameters conf.env) 1631 in 1632 do { 1633 eprintf "\n"; 1634 flush stderr; 1635 if rc > 1 then print_file conf "bsi_err.htm" else print_file conf ok_file 1636 } 1637; 1638 1639value separate_slashed_filename s = 1640 loop 0 where rec loop i = 1641 match try Some (String.index_from s i '/') with [ Not_found -> None ] with 1642 [ Some j -> 1643 if j > i then [String.sub s i (j - i) :: loop (j + 1)] 1644 else loop (j + 1) 1645 | None -> 1646 if i >= String.length s then [] 1647 else [String.sub s i (String.length s - i)] ] 1648; 1649 1650value start_with s x = 1651 let slen = String.length s in 1652 let xlen = String.length x in 1653 slen >= xlen && String.sub s 0 xlen = x 1654; 1655 1656value end_with s x = 1657 let slen = String.length s in 1658 let xlen = String.length x in 1659 slen >= xlen && String.sub s (slen - xlen) xlen = x 1660; 1661 1662value print_typed_file conf typ fname = 1663 let ic_opt = 1664 try Some (open_in_bin fname) with 1665 [ Sys_error _ -> None ] 1666 in 1667 match ic_opt with 1668 [ Some ic -> 1669 do { 1670 Wserver.http ""; 1671 Wserver.wprint "Content-type: %s" typ; 1672 nl (); 1673 Wserver.wprint "Content-length: %d" (in_channel_length ic); 1674 nl (); nl (); 1675 try 1676 while True do { 1677 let c = input_char ic in 1678 Wserver.wprint "%c" c 1679 } 1680 with [ End_of_file -> () ]; 1681 close_in ic; 1682 } 1683 | None -> 1684 let title _ = Wserver.wprint "Error" in 1685 do { 1686 header conf title; 1687 Wserver.wprint "<ul><li>\n"; 1688 Wserver.wprint "Cannot access file \"%s\".\n" fname; 1689 Wserver.wprint "</ul>\n"; 1690 trailer conf; 1691 raise Exit 1692 } ] 1693; 1694 1695value raw_file conf s = 1696 let fname = 1697 List.fold_left Filename.concat setup_dir.val 1698 (separate_slashed_filename s) 1699 in 1700 let typ = 1701 if end_with s ".png" then "image/png" 1702 else if end_with s ".jpg" then "image/jpeg" 1703 else if end_with s ".gif" then "image/gif" 1704 else if end_with s ".css" then "text/css" 1705 else "text/html" 1706 in 1707 print_typed_file conf typ fname 1708; 1709 1710value has_gwb_directories dh = 1711 try 1712 let rec loop () = 1713 let e = Unix.readdir dh in 1714 if Filename.check_suffix e ".gwb" then True else loop () 1715 in 1716 loop () 1717 with 1718 [ End_of_file -> do { Unix.closedir dh; False } ] 1719; 1720 1721value setup_comm_ok conf = 1722 fun 1723 [ "gwsetup" -> setup_gen conf 1724 | "simple" -> simple conf 1725 | "simple2" -> simple2 conf 1726 | "recover" -> recover conf 1727 | "recover_1" -> recover_1 conf 1728 | "recover_2" -> recover_2 conf 1729 | "cleanup" -> cleanup conf 1730 | "cleanup_1" -> cleanup_1 conf 1731 | "rename" -> rename conf 1732 | "delete" -> delete conf 1733 | "delete_1" -> delete_1 conf 1734 | "merge" -> merge conf 1735 | "merge_1" -> merge_1 conf 1736 | "gwc" -> 1737 match p_getenv conf.env "opt" with 1738 [ Some "check" -> gwc_check conf 1739 | _ -> gwc conf ] 1740 | "gwc2" -> 1741 match p_getenv conf.env "opt" with 1742 [ Some "check" -> gwc2_check conf 1743 | _ -> gwc2 conf ] 1744 | "gwu" -> 1745 match p_getenv conf.env "opt" with 1746 [ Some "check" -> gwu conf 1747 | _ -> gwu_1 conf ] 1748 | "ged2gwb" -> 1749 match p_getenv conf.env "opt" with 1750 [ Some "check" -> ged2gwb_check conf 1751 | _ -> ged2gwb conf ] 1752 | "ged2gwb2" -> 1753 match p_getenv conf.env "opt" with 1754 [ Some "check" -> ged2gwb2_check conf 1755 | _ -> ged2gwb2 conf ] 1756 | "gwb2ged" -> 1757 match p_getenv conf.env "opt" with 1758 [ Some "check" -> gwb2ged conf 1759 | _ -> gwb2ged_1 conf ] 1760 | "consang" -> 1761 match p_getenv conf.env "opt" with 1762 [ Some "check" -> consang_check conf 1763 | _ -> consang conf "consg_ok.htm" ] 1764 | "update_nldb" -> 1765 match p_getenv conf.env "opt" with 1766 [ Some "check" -> update_nldb_check conf 1767 | _ -> update_nldb conf "update_nldb_ok.htm" ] 1768 | "gwf" -> gwf conf 1769 | "gwf_1" -> gwf_1 conf 1770 | "gwd" -> gwd conf 1771 | "gwd_1" -> gwd_1 conf 1772 | x -> 1773 if start_with x "doc/" || start_with x "images/" || start_with x "css/" 1774 then raw_file conf x 1775 else error conf ("bad command: \"" ^ x ^ "\"") ] 1776; 1777 1778value setup_comm conf comm = 1779 match p_getenv conf.env "cancel" with 1780 [ Some _ -> 1781 setup_gen {(conf) with env = [("lang", conf.lang); ("v", "main.htm")]} 1782 | None -> setup_comm_ok conf comm ] 1783; 1784 1785value string_of_sockaddr = 1786 fun 1787 [ Unix.ADDR_UNIX s -> s 1788 | Unix.ADDR_INET a _ -> Unix.string_of_inet_addr a ] 1789; 1790 1791value local_addr = "127.0.0.1"; 1792 1793value only_addr () = 1794 let fname = only_file_name () in 1795 match try Some (open_in fname) with [ Sys_error _ -> None ] with 1796 [ Some ic -> 1797 let v = try input_line ic with [ End_of_file -> local_addr ] in 1798 do { close_in ic; v } 1799 | None -> local_addr ] 1800; 1801 1802value lindex s c = 1803 pos 0 where rec pos i = 1804 if i = String.length s then None 1805 else if s.[i] = c then Some i 1806 else pos (i + 1) 1807; 1808 1809value input_lexicon lang = 1810 let t = Hashtbl.create 501 in 1811 try 1812 let ic = 1813 open_in 1814 (List.fold_right Filename.concat [setup_dir.val; "setup"; "lang"] 1815 "lexicon.txt") 1816 in 1817 let derived_lang = 1818 match lindex lang '-' with 1819 [ Some i -> String.sub lang 0 i 1820 | _ -> "" ] 1821 in 1822 try 1823 do { 1824 try 1825 while True do { 1826 let k = 1827 find_key (input_line ic) where rec find_key line = 1828 if String.length line < 4 then find_key (input_line ic) 1829 else if String.sub line 0 4 <> " " then 1830 find_key (input_line ic) 1831 else line 1832 in 1833 let k = String.sub k 4 (String.length k - 4) in 1834 let rec loop line = 1835 match lindex line ':' with 1836 [ Some i -> 1837 let line_lang = String.sub line 0 i in 1838 do { 1839 if line_lang = lang || 1840 line_lang = derived_lang && not (Hashtbl.mem t k) then 1841 let v = 1842 if i + 1 = String.length line then "" 1843 else 1844 String.sub line (i + 2) (String.length line - i - 2) 1845 in 1846 Hashtbl.add t k v 1847 else (); 1848 loop (input_line ic) 1849 } 1850 | None -> () ] 1851 in 1852 loop (input_line ic) 1853 } 1854 with 1855 [ End_of_file -> () ]; 1856 close_in ic; 1857 t 1858 } 1859 with e -> 1860 do { close_in ic; raise e } 1861 with 1862 [ Sys_error _ -> t ] 1863; 1864 1865value setup (addr, req) comm env_str = 1866 let conf = 1867 let env = create_env env_str in 1868 if env = [] && (comm = "" || String.length comm = 2) then 1869 let lang = 1870 if comm = "" then default_lang.val else String.lowercase comm 1871 in 1872 let lexicon = input_lexicon lang in 1873 {lang = lang; comm = ""; env = env; request = req; lexicon = lexicon} 1874 else 1875 let (lang, env) = 1876 match p_getenv env "lang" with 1877 [ Some x -> (x, list_remove_assoc "lang" env) 1878 | _ -> (default_lang.val, env) ] 1879 in 1880 let lexicon = input_lexicon lang in 1881 {lang = lang; comm = comm; env = env; request = req; lexicon = lexicon} 1882 in 1883 let saddr = string_of_sockaddr addr in 1884 let s = only_addr () in 1885 if s <> saddr then do { 1886 let conf = {(conf) with env = [("anon", saddr); ("o", s)]} in 1887 eprintf "Invalid request from \"%s\"; only \"%s\" accepted.\n" 1888 saddr s; 1889 flush stderr; 1890 print_file conf "err_acc.htm" 1891 } 1892 else if conf.comm = "" then print_file conf "welcome.htm" 1893 else setup_comm conf comm 1894; 1895 1896value wrap_setup a b c = 1897 do { 1898 IFDEF WIN95 THEN do { 1899 (* another process have been launched, therefore we lost variables; 1900 and we cannot parse the arg list again, because of possible spaces 1901 in arguments which may appear as separators *) 1902 try default_lang.val := Sys.getenv "GWLANG" with [ Not_found -> () ]; 1903 try setup_dir.val := Sys.getenv "GWGD" with [ Not_found -> () ]; 1904 try bin_dir.val := Sys.getenv "GWGD" with [ Not_found -> () ] 1905 } 1906 ELSE () END; 1907 try setup a b c with [ Exit -> () ] 1908 } 1909; 1910 1911value copy_text lang fname = 1912 let dir = Filename.concat setup_dir.val "setup" in 1913 let fname = Filename.concat dir fname in 1914 match try Some (open_in fname) with [ Sys_error _ -> None ] with 1915 [ Some ic -> 1916 let conf = 1917 {lang = lang; comm = ""; env = []; request = []; 1918 lexicon = Hashtbl.create 1} 1919 in 1920 do { 1921 copy_from_stream conf print_string (Stream.of_channel ic); 1922 flush stdout; 1923 close_in ic 1924 } 1925 | _ -> 1926 do { 1927 printf "\nCannot access file \"%s\".\n" fname; 1928 printf "Type \"Enter\" to exit\n? "; 1929 flush stdout; 1930 let _ = input_line stdin in (); 1931 exit 2 1932 } ] 1933; 1934 1935value set_gwd_default_language_if_absent lang = 1936 let env = read_gwd_arg () in 1937 let fname = Filename.concat setup_dir.val "gwd.arg" in 1938 match try Some (open_out fname) with [ Sys_error _ -> None ] with 1939 [ Some oc -> 1940 let lang_found = ref False in 1941 do { 1942 List.iter 1943 (fun (k, v) -> 1944 do { 1945 fprintf oc "-%s\n" k; 1946 if k = "lang" then lang_found.val := True else (); 1947 if v <> "" then fprintf oc "%s\n" v else (); 1948 }) 1949 env; 1950 if not lang_found.val then fprintf oc "-lang\n%s\n" lang 1951 else (); 1952 close_out oc 1953 } 1954 | None -> () ] 1955; 1956 1957value daemon = ref False; 1958 1959value usage = 1960 "Usage: " ^ Filename.basename Sys.argv.(0) ^ " [options] where options are:"; 1961value speclist = 1962 [("-lang", Arg.String (fun x -> lang_param.val := x), 1963 "<string>: default lang"); 1964 ("-daemon", Arg.Set daemon, ": Unix daemon mode."); 1965 ("-p", Arg.Int (fun x -> port.val := x), 1966 "<number>: Select a port number (default = " ^ 1967 string_of_int port.val ^ "); > 1024 for normal users."); 1968 ("-only", Arg.String (fun s -> only_file.val := s), 1969 "<file>: File containing the only authorized address"); 1970 ("-gd", Arg.String (fun x -> setup_dir.val := x), 1971 "<string>: gwsetup directory"); 1972 ("-bindir", Arg.String (fun x -> bin_dir.val := x), 1973 "<string>: binary directory (default = value of option -gd)") :: 1974 IFDEF SYS_COMMAND THEN 1975 [("-wserver", Arg.String (fun _ -> ()), " (internal feature)")] 1976 ELSE [] END] 1977; 1978value anonfun s = raise (Arg.Bad ("don't know what to do with " ^ s)); 1979 1980value null_reopen flags fd = 1981 IFDEF UNIX THEN do { 1982 let fd2 = Unix.openfile "/dev/null" flags 0 in 1983 Unix.dup2 fd2 fd; 1984 Unix.close fd2 1985 } 1986 ELSE () END 1987; 1988 1989value setup_available_languages = ["de"; "en"; "es"; "fr"; "it"; "lv"; "sv"]; 1990 1991value intro () = 1992 let (default_gwd_lang, default_setup_lang) = 1993 IFDEF UNIX THEN 1994 let s = try Sys.getenv "LANG" with [ Not_found -> "" ] in 1995 if List.mem s Version.available_languages then 1996 (s, if List.mem s setup_available_languages then s else "en") 1997 else 1998 let s = try Sys.getenv "LC_CTYPE" with [ Not_found -> "" ] in 1999 if String.length s >= 2 then 2000 let s = String.sub s 0 2 in 2001 if List.mem s Version.available_languages then 2002 (s, if List.mem s setup_available_languages then s else "en") 2003 else (default_lang.val, default_lang.val) 2004 else (default_lang.val, default_lang.val) 2005 ELSE (default_lang.val, default_lang.val) END 2006 in 2007 do { 2008 Argl.parse speclist anonfun usage; 2009 if bin_dir.val = "" then bin_dir.val := setup_dir.val else (); 2010 default_lang.val := default_setup_lang; 2011 let (gwd_lang, setup_lang) = 2012 if daemon.val then 2013 IFDEF UNIX THEN do { 2014 let setup_lang = 2015 if String.length lang_param.val < 2 then default_setup_lang 2016 else lang_param.val 2017 in 2018 printf "To start, open location http://localhost:%d/\n" 2019 port.val; 2020 flush stdout; 2021 if Unix.fork () = 0 then do { 2022 Unix.close Unix.stdin; 2023 null_reopen [Unix.O_WRONLY] Unix.stdout 2024 } 2025 else exit 0; 2026 (default_gwd_lang, setup_lang) 2027 } 2028 ELSE (default_gwd_lang, default_setup_lang) END 2029 else do { 2030 let (gwd_lang, setup_lang) = 2031 if String.length lang_param.val < 2 then do { 2032 copy_text "" "intro.txt"; 2033 let x = String.lowercase (input_line stdin) in 2034 if String.length x < 2 then 2035 (default_gwd_lang, default_setup_lang) 2036 else let x = String.sub x 0 2 in (x, x) 2037 } 2038 else (lang_param.val, lang_param.val) 2039 in 2040 copy_text setup_lang (Filename.concat "lang" "intro.txt"); 2041 (gwd_lang, setup_lang) 2042 } 2043 in 2044 set_gwd_default_language_if_absent gwd_lang; 2045 default_lang.val := setup_lang; 2046 IFDEF WIN95 THEN do { 2047 Unix.putenv "GWLANG" setup_lang; Unix.putenv "GWGD" setup_dir.val 2048 } 2049 ELSE () END; 2050 printf "\n"; 2051 flush stdout 2052 } 2053; 2054 2055value main () = 2056 do { 2057 IFDEF UNIX THEN intro () 2058 ELSE IFDEF SYS_COMMAND THEN 2059 let len = Array.length Sys.argv in 2060 if len > 2 && Sys.argv.(len - 2) = "-wserver" then () else intro () 2061 ELSE 2062 try let _ = Sys.getenv "WSERVER" in () with [ Not_found -> intro () ] 2063 END END; 2064 Wserver.f None port.val 0 None wrap_setup 2065 } 2066; 2067 2068main (); 2069
