ara-1.0.31/0000755000000000000000000000000011553101133007216 5ustar ara-1.0.31/cli/0000755000000000000000000000000011553101133007765 5ustar ara-1.0.31/cli/config.ml0000644000000000000000000000014711553072340011575 0ustar (* Config *) (* $Id$ *) module C = Configuration.Make(struct let name = "ara" end)(Opt);; include C;; ara-1.0.31/cli/debug.mli0000644000000000000000000000016511553072340011567 0ustar val sf : ('a, unit, string) format -> 'a val level : int ref val enable : bool ref val debug : int -> string -> unit ara-1.0.31/cli/Makefile0000644000000000000000000000036711553072340011442 0ustar # Makefile BASE = .. EXEC = ara LIBS = $(WITHTHREADS) $(WITHSTR) $(WITHUNIX) $(WITHUTIL) \ $(WITHLEDIT) $(WITHARA) $(WITHCOMMON) $(WITHCONFIGFILE) SOURCES = debug.ml opt.ml config.ml wrap.ml pager.ml dump.ml cli.ml include Makefile.exec ara-1.0.31/cli/pager.mli0000644000000000000000000000015011553072340011571 0ustar val call : (out_channel -> 'a) -> unit val page : string -> unit val page_if_necessary : string -> unit ara-1.0.31/cli/cli.ml0000644000000000000000000007071611553072340011110 0ustar (* CLI *) (* $Id: cli.ml,v 1.1 2004/10/26 09:44:54 berke Exp $ *) open Ast open Util open Opt (*** Make *) module Make(Dpkg : Dpkg.DB) = struct module Ara = Ara.Make(Dpkg) module Dump = Dump.Make(Dpkg) open Dpkg open Dump open Ara exception Quit;; let database = new Publication.magazine;; let database_subscription = database#subscribe ();; (*** memory *) let memory () = let (miw,prw,maw) = Gc.counters () in (miw +. maw -. prw) /. 1000000.0 ;; (* ***) (*** load_database, reload_database *) let load_database ?(after = fun _ -> ()) paths = try let dbfns = Dpkg.find_database_files paths in if !Opt.progress then Printf.printf "Loading..."; let progress = if !Opt.progress then let last = ref 0.0 in fun fn count -> let t = Unix.gettimeofday () in if t > !last +. 0.5 then begin Printf.printf "\rLoaded %d packages (processing %-40s)%!" count ("\""^(limit 38 (String.escaped (Filename.basename fn)))^"\""); last := t end else () else fun _ _ -> () in let db' = Dpkg.load ~fast:!Opt.fast ~progress dbfns in if !Opt.progress then Printf.printf "\nTotal %d packages...\n%!" (Dpkg.get_count db'); database#publish `Everyone db'; after db' with | x -> Printf.printf "\nCould not load database: %s. Try: apt-get update\n" (Printexc.to_string x) ;; let database_paths () = let k = "ara.database.paths" in Configfile.to_list (Configfile.to_pair Configfile.to_string Configfile.to_string) ~k (Config.current#get k) ;; let reload_database () = Printf.printf "Reloading database...\n%!"; load_database (database_paths ()) ;; (* ***) (*** error display *) let put_arrows i j = for h = 1 to i do print_char ' ' done; for h = i to j do print_char '^'; done; print_char '\n' ;; let heap_compaction() = let (rsz1,vsz1) = Util.proc_get_rsz_vsz () in Printf.printf "Starting heap compaction...\n%!"; Gc.compact (); let (rsz2,vsz2) = Util.proc_get_rsz_vsz () in Printf.printf "Compaction saved %d resident and %d virtual pages.\n" (rsz1 - rsz2) (vsz1 - vsz2) ;; let show_highlighted out w i j n = let m = String.length w in let j = max 0 (min (m - 1) j) in let b = min (n / 3) (j - i + 1) in let ps = min (m - b) (n - b) in let s = min (m - j - 1) ((ps + 1) / 2) in let p = min i (ps - s) in let s = min (m - j - 1) (ps - p) in let p_i = i - p in let hi_i = if p_i > 0 then begin out "..."; out (String.sub w p_i p); p + 3 end else begin out (String.sub w 0 p); p end in if b < j - i + 1 then begin let b' = b - 3 in let bl = b' / 2 in let br = b' - bl in out (String.sub w i bl); out "..."; out (String.sub w (j - br) br) end else out (String.sub w i b); if j + 1 + s < m then begin out (String.sub w (j + 1) s); out "..." end else out (String.sub w (j + 1) s); out "\n"; put_arrows hi_i (hi_i + b - 1) ;; let escape_and_record_indexes w l = let m = String.length w in let b = Buffer.create m in let r = ref [] in for i = 0 to m - 1 do if List.mem i l then r := (i,Buffer.length b)::!r; Buffer.add_string b (String.escaped (String.make 1 w.[i])) done; if List.mem m l then r := (m,Buffer.length b)::!r; (Buffer.contents b,!r) ;; let lower_half x = x / 2 let upper_half x = x - (x / 2) let show_parse_error i j x w = let m = String.length w in if m = 0 then Printf.printf "Error: Syntax error -- Empty query.\n" else begin Printf.printf "Error: Syntax error %s of query --- %s:\n" (if i = j then if i >= m - 1 then "end" else sf "at character %d" (i + 1) else "between "^ (if i = 0 then "beginning" else sf "character %d" (i + 1))^ " and "^ (if j >= m - 1 then "end" else sf "character %d" (j + 1))) x; let (w',z) = escape_and_record_indexes w [i;j] in let m = String.length w' and i' = List.assoc i z and j' = List.assoc j z in (* show string w' highlighting i' to j' on columns columns *) let w' = if j' >= m - 1 then w'^" " else w' in show_highlighted print_string w' i' j' !Opt.columns end ;; (* Error display ***) module SM = Map.Make(String);; exception Variable_not_found of string;; (*** compute_interactive_command *) let compute_interactive_command cmd = let runi = Config.current#get_string "ara.commands.run_interactive_command" in Util.substitute_variables ["COMMAND",cmd] runi ;; (* ***) (*** eval *) let eval db env q w = let pl = Ara.compute_query db ~get:(fun id -> try let (_,r,_) = SM.find id !env in r with | Not_found -> raise (Variable_not_found id)) ~set:(fun id r s1 s2 q -> let w' = try String.sub w s1 (s2 - s1) with | _ -> sf "??? %d,%d" s1 s2 in env := SM.add id (w',r,q) !env) q in pl ;; (* ***) (*** yes_no *) let yes_no msg = flush stdout; let p = Ledit.get_prompt () in Ledit.set_prompt msg; let rec loop () = let u = Ledit.read_line () in match String.lowercase u with | "y"|"yes" -> `Yes | "n"|"no" -> `No | _ -> Printf.printf "Please answer YES or NO.\n"; loop () in let ans = loop () in Ledit.set_prompt p; ans ;; (* ***) (*** process *) exception Sorry of string;; let process db env ?(output=`Stdout) ?(interactive=false) (style,fields,q,w) = let count = ref 0 in let show_count = ref true in let with_result f = let rec once db = let xl = eval db env q w in let xl = if !Opt.coalesce then Ara.filter_old_versions db xl else xl in count := List.length xl; match q with | Ast.Assign(id,_,_,_) -> Printf.printf "%s: %d packages.\n" id !count; show_count := false | _ -> let xl = List.sort (fun i j -> compare (name_of db i) (name_of db j)) xl in if xl = [] then Printf.printf "(No packages).\n" else f db xl in try database_subscription#with_last_issue once with | Virtual_strings.File_out_of_date(fn) -> Printf.printf "File %S changed.\n" fn; reload_database (); database_subscription#with_last_issue once in try let oc = match output with | `Print -> let cmd = Config.current#get_string "ara.commands.print" in Unix.open_process_out cmd | `Stdout -> stdout | `New f -> begin try let st = Unix.stat f in match st.Unix.st_kind with | Unix.S_REG -> raise (Sorry(sf "File %S already exists. (Try >> or >|)." f)) | _ -> open_out f with | Unix.Unix_error(Unix.ENOENT,_,_) -> open_out f | x -> raise x end | `Overwrite f -> open_out f | `Append f -> open_out_gen [Open_append;Open_creat] 0o644 f in let wrapper w = if !Opt.wrap then new Wrap.word_wrapper ~columns:!Opt.columns w else new Wrap.word_non_wrapper ~columns:!Opt.columns w in let dont_page f = f (wrapper (new Wrap.writer_of_output_channel oc)) in let page_if_necessary f = if output = `Stdout & !Opt.use_pager & interactive then begin let w = new Wrap.counter in f (wrapper w); if w#row >= !Opt.rows then Pager.call (fun oc -> f (wrapper (new Wrap.writer_of_output_channel oc))) else dont_page f end else dont_page f in try begin match style with | `Install|`Remove -> with_result (fun db xl -> let remove = style = `Remove in show_count := false; let xl = if !Opt.coalesce then xl else Ara.filter_old_versions db xl in let m = List.length xl in let w = new Wrap.counter in let ww = new Wrap.word_wrapper ~columns:!Opt.columns w in Dump.bourbaki_dump ww ~versions:true db xl; if w#row + 1 > !Opt.rows then begin Printf.printf "You have asked to %s %d package%s.\n" (if remove then "remove" else "install") m (if m = 1 then "" else "s"); if `Yes = yes_no "Would you like to view a list of these packages ? (yes/no) " then begin Pager.call (fun oc -> let w = new Wrap.writer_of_output_channel oc in let ww = new Wrap.word_wrapper ~columns:!Opt.columns w in bourbaki_dump ww ~versions:true db xl) end else () end else begin Printf.printf "Are you sure you want to %s the following package%s ?\n" (if remove then "remove" else "install") (if m = 1 then "" else "s"); let w = new Wrap.writer_of_output_channel stdout in let ww = new Wrap.word_wrapper ~columns:!Opt.columns w in bourbaki_dump ww ~versions:true db xl end; if `No = yes_no (sf "%s packages ? (yes/no) " (if remove then "Remove" else "Install")) then Printf.printf "Very well.\n" else List.iter (fun i -> let pn = Dpkg.name_of db i and pv = Dpkg.version_of db i in let cmd = Util.substitute_variables ["PACKAGE",pn; "VERSION",pv] (if remove then Config.current#get_string "ara.commands.remove" else Config.current#get_string "ara.commands.install") in let icmd = compute_interactive_command cmd in let rc = Sys.command icmd in if rc <> 0 then Printf.printf "%s of %S (%S) failed with code %d.\n" (if remove then "Removal" else "Installation") pn pv rc else Printf.printf "%s of %S (%S) succeeded.\n" (if remove then "Removal" else "Installation") pn pv) xl) | `Bourbaki -> with_result (fun db xl -> page_if_necessary (fun ww -> Dump.bourbaki_dump ww ~versions:(not !Opt.coalesce) db xl)) | `List -> with_result (fun db xl -> page_if_necessary (fun ww -> Dump.list_dump ww ~versions:(not !Opt.coalesce) db xl)) | `Raw -> with_result (fun db xl -> page_if_necessary (fun ww -> Dump.raw_dump ww db fields xl)) | `Table -> with_result (fun db xl -> if output = `Stdout & !Opt.use_pager & interactive then begin let w = new Wrap.counter in table_dump w db fields ~borders:!Opt.borders xl; if w#row + 1 >= !Opt.rows then Pager.call (fun oc -> let w = new Wrap.writer_of_output_channel oc in table_dump w db fields ~borders:!Opt.borders xl) else let w = new Wrap.writer_of_output_channel stdout in table_dump w db fields ~borders:!Opt.borders xl end else let w = new Wrap.writer_of_output_channel oc in table_dump w db fields ~borders:!Opt.borders xl) | `Count -> with_result (fun db xl -> show_count := false; Printf.fprintf oc "%d\n" (List.length xl)) | `Ast -> Ast.dump Format.err_formatter q; Format.fprintf Format.err_formatter "@?" end; match output with | `Stdout -> () | `Print -> begin match Util.string_of_process_status "Printing" (Unix.close_process_out oc) with | None -> () | Some x -> Printf.printf "%s\n" x end | _ -> close_out oc with | x -> if output <> `Stdout then close_out oc; raise x with | Sorry(x) -> Printf.printf "Sorry: %s\n" x | Virtual_strings.File_out_of_date(fn) -> Printf.printf "The database file %S has changed. Please type #reload.\n" fn | Unix.Unix_error(ue,x,y) -> Printf.printf "Error: %s (%S, %S).\n" (Unix.error_message ue) x y (*| x -> Printf.printf "Error: %s\n" (Printexc.to_string x)*) ;; (* ***) (*** toplevel *) let toplevel ?(catcher=(fun x -> raise x)) f = Ledit.init (); if !Opt.save_history then begin Config.current#ensure_directory_presence; Ledit.open_histfile false (Config.current#path "history"); end; Ledit.set_max_len !Opt.columns; Ledit.set_prompt "& "; Printf.printf "Welcome to ara version %s released on %s.\n" Version.version Version.date; Printf.printf "Type ? for help and Ctrl-D or #quit to exit.\n"; let bye () = if !Opt.save_history then Ledit.close_histfile () in let rec loop () = try while true do flush stdout; let w = Ledit.read_line () in if w <> "" then f w else () done with | End_of_file -> Printf.printf "\nEOF.\n%!"; bye () | Quit -> bye () | x -> if catcher x then loop () else bye () in loop () ;; (* ***) (*** Interactive *) exception Bad_field of string;; let parse_fieldspec db w = let fd = Opt.initial_parse_fieldspec w in match fd with | All -> fd | These l -> List.iter (fun (f,_) -> try ignore (Dpkg.field_of_string db (String.lowercase f)) with | Not_found -> raise (Bad_field f)) l; fd ;; (* Command parsing is not elegant and sucks. *) module Interactive = struct let style : Opt.style ref = ref `Bourbaki let fields = Opt.fields let type_help_for_help () = Printf.printf "Type #help for help.\n" let bad_syntax = once type_help_for_help;; let unknown_directive = once type_help_for_help;; let option_keywords = List.map (fun (x,y,z) -> if x <> "" && x.[0] = '-' then String.sub x 1 (String.length x - 1) else x) Opt.cli_specs ;; let catcher x = begin match x with | Bad_field(f) -> Printf.printf "Error: unknown field %S.\n" f | Unix.Unix_error(ue,x,y) -> Printf.printf "UNIX error: %s (%S, %S).\n" (Unix.error_message ue) x y | x -> Printf.printf "Error: %s\n" (Printexc.to_string x); if !Opt.raise_exceptions then raise x end; true let do_command nm vr = let icmd = compute_interactive_command (Config.current#get_string vr) in let rc = Sys.command icmd in if rc <> 0 then Printf.printf "APT %s failed with code %d.\n" nm rc else Printf.printf "APT %s succeeded.\n" nm ;; let show_memory () = let pgsz = Config.current#get_int ~default:4096 "ara.misc.page_size" in let (rsz,vsz) = Util.proc_get_rsz_vsz () in Printf.printf "Memory usage is %d pages virtual, %d pages resident.\n\ With a page size of %d bytes this gives %.1fMiB virtual \ and %.1fMiB resident.\n\ Approximatively %.1f million words have been allocated.\n\ Current backend: %s\n" rsz vsz pgsz ((float pgsz) *. (float rsz) /. 1048576.0) ((float pgsz) *. (float vsz) /. 1048576.0) (memory ()) Dpkg.backend ;; (*** directive *) let rec directive db env ?(output=`Stdout) w = let with_style st fd v = if v <> "" && not (Util.for_all_chars Util.is_space v) then let style',fields' = !style,!fields in Util.wind (fun () -> style := st; fields := fd; interactive env ~output v) () (fun () -> style := style'; fields := fields') () else begin style := st; fields := fd; Printf.printf "Default output style set to %s with %s.\n" (match st with | `Bourbaki -> "Bourbaki" | `List -> "list" | `Raw -> "raw" | `Table -> "table" | `Count -> "count" | `Ast -> "ast" | `Install -> "install" | `Remove -> "install") (match fd with | All -> "all fields" | These(l) -> if l = [] then "NO fields" else "these fields: "^(String.concat "," (List.map (function | (f,None) -> f | (f,Some x) -> sf "%s:%d" f x) l))) end in let (u,v) = Util.split_once_at is_space w in match u with | "#syntax" -> Pager.page Help.syntax | "#help" -> Pager.page_if_necessary Help.cli_help | "#examples" -> Pager.page_if_necessary Help.cli_examples | "#shell" -> begin try let v = Util.remove_leading_spaces v in let v = if v = "" then try Sys.getenv "SHELL" with | Not_found -> "/bin/sh" else v in let rc = Sys.command v in if rc <> 0 then Printf.printf "Command returned code %d.\n" rc with | x -> Printf.printf "Command failed: %s.\n" (Printexc.to_string x) end | "#about" -> print_string Help.about | "#version" -> Printf.printf "This is ara version %s released on %s.\n" Version.version Version.date | "#reload" -> reload_database () | "#short"|"#bourbaki" -> with_style `Bourbaki !fields v | "#list" -> with_style `List !fields v | "#raw"|"#show" -> with_style `Raw !fields v | "#memory" -> show_memory () | "#memorystats" -> Gc.print_stat stdout | "#print" -> interactive env ~output:`Print v | "#compact" -> heap_compaction() | "#fields" -> begin let (v1,v2) = Util.split_once_at is_space v in let v1 = Util.remove_leading_spaces v1 in if v1 = "" then with_style !style !fields v2 else let fd = parse_fieldspec db v1 in with_style !style fd v2 end | "#all" -> with_style `Raw All v | "#ast" -> with_style `Ast !fields v | "#table"|"#tabular" -> with_style `Table !fields v | "#count" -> with_style `Count !fields v | "#install" -> with_style `Install !fields v | "#remove" -> with_style `Remove !fields v | "#quit"|"#q"|"#bye" -> raise Quit | "#update" -> do_command "update" "ara.commands.update"; reload_database(); heap_compaction() | "#upgrade" -> do_command "upgrade" "ara.commands.upgrade" | "#dist-upgrade" -> do_command "dist-upgrade" "ara.commands.dist_upgrade" | "#set" -> let options = ref [] in let current = ref 0 in let a = Array.of_list ("CLI"::(Util.parse_strings v)) in let help_string = "Type #set [options]. The syntax is the same as when calling ara \ from the shell. Dashes preceding keywords may be omitted." in begin try let qb = Buffer.create 16 in Opt.queries := []; Arg.parse_argv ~current a Opt.cli_specs (fun w -> options := (if List.mem w option_keywords then "-"^w else w)::!options) help_string; if !options <> [] then begin let a' = Array.of_list ("CLI"::(List.rev !options)) in current := 0; Arg.parse_argv ~current a' Opt.cli_specs (fun w -> Buffer.add_char qb ' '; Buffer.add_string qb w) (* Printf.printf "Error: Unexpected option %S.\n" w) *) help_string; end else (); let w = Buffer.contents qb in let q = !Opt.queries in if not (Util.for_all_chars Util.is_space w) then interactive env ~output w else (); List.iter (fun (style,fields,w) -> interactive_statement db env ~output style fields w) !Opt.queries; with | Arg.Bad(x) -> print_string ((first_line x)^"\n"); (* hack *) | Arg.Help(x) -> print_string x | x -> raise x (* Printf.printf "Error: %s\n" (Printexc.to_string x) *) end | x -> Printf.printf "Unknown directive %S.\n" x; unknown_directive () (* directive ***) (*** interactive *) and interactive env ?(output=`Stdout) (w : string) = database_subscription#with_last_issue (fun db -> let w = Util.remove_leading_spaces w in if w <> "" then if w.[0] = '>' then if String.length w > 1 then if is_space w.[1] or (w.[1] <> '|' && w.[1] <> '>') then let w = Util.delete_first_chars 1 w in let w = Util.remove_leading_spaces w in let (u,v) = Util.split_once_at is_space w in interactive env ~output:(`New u) v else if w.[1] = '|' then let w = Util.delete_first_chars 2 w in let w = Util.remove_leading_spaces w in let (u,v) = Util.split_once_at is_space w in interactive env ~output:(`Overwrite u) v else if w.[1] = '>' then let w = Util.delete_first_chars 2 w in let w = Util.remove_leading_spaces w in let (u,v) = Util.split_once_at is_space w in interactive env ~output:(`Append u) v else Printf.printf "Bad redirection.\n" else Printf.printf "Bad redirection.\n" else if w.[0] = '#' then directive db env ~output w else if w.[0] = '?' then Pager.page_if_necessary Help.cli_help else interactive_statement db env ~output !style !fields w else ()) (* ***) (*** interactive_statement *) and interactive_statement db env ?(output=`Stdout) style fields w = let q = try Some(statement_of_string w) with | Parse_error(i,j,x) -> show_parse_error i j x w; bad_syntax (); flush stdout; None | x -> Printf.printf "Error: %s.\n" (Printexc.to_string x); None in match q with | None -> () | Some(q) -> try process db env ~output ~interactive:true (style,fields,q,w) with | Variable_not_found(x) -> Printf.printf "Error: variable %S not found.\n" x (*| x -> Printf.printf "An uncaught exception occurred: %s\n" (Printexc.to_string x) XXX *) (* ***) end ;; (* ***) let main () = List.iter (fun (fn,ex) -> if fn <> !Opt.config_file or (!Opt.user_specified_config_file & fn = !Opt.config_file) or (match ex with Sys_error(_) -> false | _ -> true) then Printf.printf "Error loading config file %S: %s.\n" fn (Printexc.to_string ex)) (Config.load ()); let queries' = List.map (fun (style,fields,w) -> try let q = statement_of_string w in if !Opt.ast then begin Ast.dump Format.err_formatter q; Format.fprintf Format.err_formatter "@."; end; (style,fields,q,w) with | Parse_error(i,j,x) -> show_parse_error i j x w; exit 1) !Opt.queries in if queries' = [] && not !Opt.interactive then begin print_string "Error: No queries given and -interactive option not set; \ try -help or -examples.\n"; exit 1 end else load_database (database_paths ()); if !Opt.interactive then heap_compaction(); let env = ref SM.empty in database_subscription#with_last_issue (fun db' -> List.iter (process db' env) queries'; if !Opt.interactive then Opt.parse_fieldspec := parse_fieldspec db'); if !Opt.interactive then toplevel ~catcher:Interactive.catcher (fun w -> Interactive.interactive env w) else () ;; end (* ***) (*** Main *) let _ = Arg.parse Opt.specs Opt.add_query (Printf.sprintf "Usage: %s " Sys.argv.(0)); if !Opt.very_slow then let module M = Make(Dpkg.DBFS) in M.main () else let module M = Make(Dpkg.DBRAM) in M.main () ;; (* Main ***) ara-1.0.31/cli/dump.mli0000644000000000000000000000204711553072340011447 0ustar module Make : functor (Dpkg : Dpkg.DB) -> sig val iter_over_packages : 'a -> 'b list -> ('b -> unit) -> unit val sf : ('a, unit, string) format -> 'a val bourbaki_dump : < flush : 'a; output_word : string -> unit; .. > -> versions:bool -> Dpkg.db -> int list -> 'a val list_dump : < flush : unit; output_word : string -> unit; .. > -> versions:bool -> Dpkg.db -> int list -> unit val default_field_order : string list * string list val compute_fields : ?field_order:string list * string list -> Dpkg.db -> 'a -> int list * int list * int list val raw_dump : < columns : int; flush : unit; newline : unit; output : string -> unit; output_word : string -> 'a; .. > -> Dpkg.db -> Opt.fields -> int list -> unit val table_dump : < output_char : char -> unit; output_string : string -> unit; .. > -> Dpkg.db -> ?field_order:string list * string list -> borders:bool -> Opt.fields -> int list -> unit end ara-1.0.31/cli/wrap.ml0000644000000000000000000001106111553072340011276 0ustar (* Wrap *) (* $Id$ *) (*** counter *) class counter = object(self) val mutable row = 0 val mutable col = 0 method row = row method col = col method private count_char c = match c with | '\n' -> col <- 0; row <- row + 1 | '\t' -> col <- col + 4 - (col land 3) | _ -> col <- col + 1 method output_char c = self#count_char c method output_substring u i m = for k = 0 to m - 1 do self#count_char u.[i + k] done method output_string u = for i = 0 to String.length u - 1 do self#count_char u.[i] done method flush = () end ;; (* ***) (*** writer_of_output_channel *) class writer_of_output_channel oc = object(self) inherit counter as super method output_string u = super#output_string u; output_string oc u method output_substring u i m = super#output_substring u i m; output oc u i m method output_char c = super#output_char c; output_char oc c method flush = super#flush; flush oc end ;; (* ***) (*** word_wrapper *) class word_wrapper ?(columns=75) writer = object(self) val mutable j = 0 method columns = columns method flush = if j > 0 then self#newline method newline = writer#output_char '\n'; j <- 0 method output_word u = let m = String.length u in if j > 0 then if j + m + 1 >= columns then begin writer#output_char '\n'; j <- 0; end else () else (); if j > 0 then begin writer#output_char ' '; j <- j + 1 end; writer#output_string u; if j + m >= columns then begin writer#output_char '\n'; j <- 0; end else j <- j + m method output u = let m = String.length u in let f c = writer#output_char c and g u i m = writer#output_substring u i m in (* beginning of line space *) (* i: current index *) (* j: pending beginning-of-line spaces (i.e., indent) *) let rec loop0 i j = if i = m then if j > 0 then f '\n' else () else match u.[i] with | ' ' -> loop0 (i + 1) (j + 1) | '\t' -> loop0 (i + 1) (j + (4 - j land 3)) | '\n' -> f '\n'; loop0 (i + 1) 0 | _ -> if j < columns then loop2 i i 0 j else begin f '\n'; loop2 i i 0 0 end (* inter-word space *) (* i: current index *) (* j: actual column *) and loop1 i j = if i >= m then if j > 0 then f '\n' else () else match u.[i] with (* XXX bug here *) | ' '|'\t' -> loop1 (i + 1) j | '\n' -> f '\n'; loop0 (i + 1) 0 | _ -> loop2 i i j 1 (* word *) (* i0: index of beginning of word *) (* i: current index *) (* j: actual cursor column *) (* k: number of pending spaces *) and loop2 i0 i j k = if i = m or u.[i] = ' ' or u.[i] = '\t' or u.[i] = '\n' then let l = i - i0 in if j + k + l >= columns then begin f '\n'; g u i0 l; if i < m & u.[i] = '\n' then begin f '\n'; loop0 (i + 1) 0 end else if l >= columns then begin f '\n'; loop1 (i + 1) 0 end else loop1 (i + 1) l end else begin for h = 1 to k do f ' ' done; g u i0 l; if i = m or i < m && u.[i] = '\n' then begin f '\n'; if i < m then loop0 (i + 1) 0 end else loop1 (i + 1) (j + k + l) end else loop2 i0 (i + 1) j k in loop0 0 j end ;; (* ***) (*** word_non_wrapper *) class word_non_wrapper ?(columns=75) writer = object(self) method columns = columns method flush = if writer#col > 0 then self#newline method newline = writer#output_char '\n' method output_word u = if writer#col > 0 then begin writer#output_char ' ' end; writer#output_string u method output (u : string) : unit = writer#output_string u end ;; (* ***) ara-1.0.31/cli/cli.mli0000644000000000000000000000000011553072340011234 0ustar ara-1.0.31/cli/dump.ml0000644000000000000000000001420611553072340011276 0ustar (* Dump *) (* $Id: dump.ml,v 1.1 2004/10/26 09:44:54 berke Exp $ *) module Make(Dpkg : Dpkg.DB) = struct open Dpkg open Opt let iter_over_packages db x f = List.iter f x;; let sf = Printf.sprintf;; (*** bourbaki_dump_abstract *) let bourbaki_dump writer ~versions db x = iter_over_packages db x (fun i -> try let p = name_of db i in if versions then writer#output_word (p^"("^(version_of db i)^")") else writer#output_word p with | Not_found -> writer#output_word (sf "(%d)" i)); writer#flush ;; (* ***) (*** list_dump *) let list_dump writer ~versions db x = iter_over_packages db x (fun i -> try if versions then writer#output_word (sf "%s (%s)" (name_of db i) (version_of db i)) else writer#output_word (sf "%s" (name_of db i)); writer#flush with | Not_found -> writer#output_word (sf "package-%d" i)) ;; (* ***) let default_field_order = ["Package"],["Description"];; (*** compute_fields *) let compute_fields ?(field_order=default_field_order) db fd = let (pre_fields, post_fields) = field_order in let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in let pre_fields = convert pre_fields and post_fields = convert post_fields in let fields = get_fields db in let rec other i r = if i = Array.length fields then r else other (i + 1) (if List.mem i pre_fields or List.mem i post_fields then r else i::r) in let other_fields = other 0 [] in (pre_fields, other_fields, post_fields) ;; (* ***) (*** raw_dump *) let raw_dump writer db fd x = let pf = new Dpkg.paragraph_folder in let columns = writer#columns in let (pre_fields, other_fields, post_fields) = compute_fields db fd in let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in let f = match fd with | All -> fun g -> List.iter g pre_fields; List.iter g other_fields; List.iter g post_fields | These l -> let l' = convert (List.map (fun (x,_) -> x) l) in let pre_fields = Util.list_intersect l' pre_fields and other_fields = Util.list_intersect l' other_fields and post_fields = Util.list_intersect l' post_fields in fun g -> List.iter g pre_fields; List.iter g other_fields; List.iter g post_fields in let sep = String.make columns '-' in let nearly = ref false in iter_over_packages db x (fun i -> if !nearly then writer#newline else nearly := true; writer#output_word sep; writer#flush; f (fun j -> let u = get_field db i j in if u <> "" then begin try ignore (String.index u '\n'); pf#reset; pf#add_string u; writer#output (sf "%s: %s" (display_name_of_field db j) (pf#get)) with | Not_found -> writer#output (sf "%s: %s\n" (display_name_of_field db j) u) end else ()); writer#flush; writer#output_word sep; writer#flush); ;; (* ***) (*** table_dump *) let table_dump writer db ?(field_order=default_field_order) ~borders fd x = let headers = borders in let (pre_fields, post_fields) = field_order in let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in let pre_fields = convert pre_fields and post_fields = convert post_fields in let fields = get_fields db in let l = match fd with | All -> let rec other i r = if i = Array.length fields then r else other (i + 1) (if List.mem i pre_fields or List.mem i post_fields then r else (i,None)::r) in other 0 [] | These(l) -> List.map (fun (w,x) -> (field_of_string db (String.lowercase w), x)) l in (*List.fold_left (fun cols i -> SM.fold (fun key _ cols -> SS.add key cols) db.db.(i) cols) SS.empty x*) let a = Array.of_list l in let n = Array.length a in let b = if headers then Array.map String.length (get_display_names db) else Array.make (Array.length (get_display_names db)) 0 in (* compute maximum width *) for i = 0 to Array.length b - 1 do iter_over_packages db x (fun j -> (* iterate on packages *) b.(i) <- max b.(i) (String.length (Util.first_line (get_field db j i)))) done; let b = Array.mapi (fun i x -> try match List.assoc i l with | None -> x | Some y -> min x y with | Not_found -> 0) b in let total = Array.fold_left (+) 0 b in let dashes () = begin for i = 0 to n - 1 do writer#output_string "+--"; let (fd,_) = a.(i) in for j = 0 to b.(fd) - 1 do writer#output_char '-' done; done; writer#output_char '+'; writer#output_char '\n' end in let spaces n = for i = 1 to n do writer#output_char ' ' done in if headers then begin if borders then dashes (); if borders then writer#output_string "| "; let display_names = get_display_names db in for i = 0 to n - 1 do if i > 0 then writer#output_char ' '; let (fd,_) = a.(i) in let w = display_names.(fd) in writer#output_string w; spaces (b.(fd) - String.length w); if borders then writer#output_string " |" done; writer#output_char '\n'; end; if borders then dashes (); iter_over_packages db x (fun i -> (* iterate over packages *) if borders then writer#output_string "| "; for j = 0 to n - 1 do if j > 0 then writer#output_char ' '; let (fd,lm) = a.(j) in let w = Util.first_line (get_field db i fd) in let p = match lm with | None -> String.length w | Some p -> p in let w = Util.limit p w in writer#output_string w; if borders or j < n - 1 then spaces (b.(fd) - String.length w); if borders then writer#output_string " |" done; writer#output_char '\n'); if borders then dashes () ;; (* ***) end ara-1.0.31/cli/opt.mli0000644000000000000000000000200611553072340011277 0ustar type style = [ `Ast | `Bourbaki | `Count | `Install | `List | `Raw | `Remove | `Table ] and fields = All | These of (string * int option) list val initial_parse_fieldspec : string -> fields val parse_fieldspec : (string -> fields) ref val user_specified_config_file : bool ref val config_file : string ref val create_config : bool ref val save_history : bool ref val ast : bool ref val interactive : bool ref val terse : bool ref val borders : bool ref val style : style ref val fields : fields ref val queries : (style * fields * string) list ref val use_pager : bool ref val columns : int ref val rows : int ref val coalesce : bool ref val progress : bool ref val user_set_progress : bool ref val wrap : bool ref val fast : bool ref val very_slow : bool ref val raise_exceptions : bool ref val batch_specs : (string * Arg.spec * string) list val add_query : string -> unit val common_specs : (string * Arg.spec * string) list val specs : (Arg.key * Arg.spec * Arg.doc) list val cli_specs : (Arg.key * Arg.spec * Arg.doc) list ara-1.0.31/cli/pager.ml0000644000000000000000000000215511553072340011427 0ustar (* Pager *) (* $Id$ *) let call f = let old_behavior = Sys.signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) in let restore () = Sys.set_signal Sys.sigpipe old_behavior in let cmd = Config.current#get_string "ara.commands.pager" in let close oc = Sys.set_signal Sys.sigpipe Sys.Signal_ignore; begin try match Util.string_of_process_status (Printf.sprintf "Pager command (%S)" cmd) (Unix.close_process_out oc) with | None -> () | Some x -> Printf.printf "%s.\n" x with | x -> Debug.debug 1 (Debug.sf "Pager: close_process_out: %s" (Printexc.to_string x)); () end in try let oc = Unix.open_process_out cmd in try f oc; close oc with | x -> close_out_noerr oc; close oc; raise x with | End_of_file -> restore (); | x -> restore (); raise x ;; let page text = call (fun oc -> output_string oc text);; let page_if_necessary text = if !Opt.use_pager & Util.count_lines text + 1 > !Opt.rows then call (fun oc -> output_string oc text) else print_string text ;; ara-1.0.31/cli/wrap.mli0000644000000000000000000000250011553072340011445 0ustar class counter : object val mutable col : int val mutable row : int method col : int method private count_char : char -> unit method flush : unit method output_char : char -> unit method output_string : string -> unit method output_substring : string -> int -> int -> unit method row : int end class writer_of_output_channel : out_channel -> object val mutable col : int val mutable row : int method col : int method private count_char : char -> unit method flush : unit method output_char : char -> unit method output_string : string -> unit method output_substring : string -> int -> int -> unit method row : int end class word_wrapper : ?columns:int -> < output_char : char -> unit; output_string : string -> 'a; output_substring : string -> int -> int -> 'b; .. > -> object val mutable j : int method columns : int method flush : unit method newline : unit method output : string -> unit method output_word : string -> unit end class word_non_wrapper : ?columns:int -> < col : int; output_char : char -> unit; output_string : string -> unit; .. > -> object method columns : int method flush : unit method newline : unit method output : string -> unit method output_word : string -> unit end ara-1.0.31/cli/debug.ml0000644000000000000000000000042311553072340011413 0ustar (* Debug *) (* $Id: debug.ml,v 1.2 2004/10/24 20:27:24 berke Exp $ *) let sf = Printf.sprintf;; let level = ref 0;; let enable = ref false;; let debug l x = if !enable && l >= !level then begin Printf.eprintf "debug(%03d): %s\n%!" l x end else () ;; ara-1.0.31/cli/config.mli0000644000000000000000000000075111553072340011747 0ustar module C : sig val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list end val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list ara-1.0.31/cli/opt.ml0000644000000000000000000001360411553072340011134 0ustar (* Opt *) (* $Id$ *) type style = [ `Bourbaki | `List | `Raw | `Table | `Count | `Ast | `Install | `Remove ] and fields = All | These of (string * int option) list ;; let initial_parse_fieldspec x = if x = "*" then All else These(List.map (fun w -> try let i = String.index w ':' in if i + 1 = String.length w then failwith "Width specifier invalid" else let n = try int_of_string (String.sub w (i + 1) (String.length w - i - 1)) with _ -> raise (Arg.Bad "Width specifier invalid") in (String.sub w 0 i,Some n) with Not_found -> (w,None)) (Util.split_at ',' x)) ;; let parse_fieldspec = ref initial_parse_fieldspec;; let user_specified_config_file = ref false let config_file = ref "ara.config" let create_config = ref true let save_history = ref true let ast = ref false let interactive = ref false let terse = ref false let borders = ref true let style : style ref = ref `Bourbaki let fields = ref (These["Package",Some 20;"Version",Some 10;"Description",Some 45]) let queries : (style * fields * string) list ref = ref [] let use_pager = ref true let columns = ref (try max 10 (int_of_string (Sys.getenv "COLUMNS") - 5) with _ -> 75) let rows = ref (try max 1 (int_of_string (Sys.getenv "LINES")) with _ -> 25) let coalesce = ref true let progress = ref false let user_set_progress = ref false let wrap = ref true let fast = ref true let low_memory = ref 32768 let very_slow = ref (Util.proc_get_free_mem () < !low_memory);; let raise_exceptions = ref false let batch_specs = [ "-examples", Arg.Unit(fun () -> print_string Help.examples; exit 0), " Display some documentation including examples exit."; "-interactive",Arg.Unit(fun () -> interactive := true; if not !user_set_progress then progress := true), " Interactive mode ; prompt for a query, display it."; "-i",Arg.Unit(fun () -> interactive := true; if not !user_set_progress then progress := true), " Same as -interactive."; "-noconfig",Arg.Clear(create_config), " Don't attempt to create a configuration file."; "-nohistory",Arg.Clear(save_history), " Don't save command history."; "-config",Arg.String(fun w -> config_file := w; user_specified_config_file := true), " Specify alternate config file (default ~/.ara/ara.config)"; "-fast",Arg.Clear(very_slow), " Run faster but use more memory."; "-slow",Arg.Set(very_slow), " Use minimal amount of memory but run very slowly."; "-cache-strings",Arg.Clear(fast), " With -fast, try to conserve memory somewhat." ];; let add_query w = queries := (`List,!fields,w)::!queries;; let common_specs = [ "-version", Arg.Unit(fun () -> Printf.printf "ara version %s released %s under the GNU GPL by Berke Durak.\n" Version.version Version.date; if not !interactive then exit 0), " Print version."; "-about", Arg.Unit(fun () -> print_string Help.about; if not !interactive then exit 0), " Display copyright, thanks and dedication."; "-progress",Arg.Tuple[Arg.Set(progress); Arg.Set(user_set_progress)], " Show progress indicator when loading database."; "-noprogress",Arg.Tuple[Arg.Clear(progress); Arg.Set(user_set_progress)], " Don't show progress indicator."; "-new",Arg.Set(coalesce), " Show only newest version of each package. (default)"; "-old",Arg.Clear(coalesce), " List all versions of packages."; "-query", Arg.String(add_query), " Query (eg. depends:xlibs & !package:xcalc)."; "-q", Arg.String(add_query), " Same as -query."; "-short",Arg.String(fun x -> queries := (`Bourbaki,!fields,x)::!queries), " Display names of packages satisfying query between a pair of curly braces."; "-list",Arg.String(fun x -> queries := (`List,!fields,x)::!queries), " Same, but display one package name per line, and no curly braces (default)."; "-raw",Arg.String(fun x -> queries := (`Raw,!fields,x)::!queries), " For each package satisfying the query, display all selected fields."; "-table",Arg.String(fun x -> queries := (`Table,!fields,x)::!queries), " Display results as a table."; "-count",Arg.String(fun x -> queries := (`Table,!fields,x)::!queries), " Display number of matching packages."; "-rows",Arg.Set_int(rows), " Set height of terminal for interactive display (default 25)"; "-columns",Arg.Set_int(columns), " Set width of terminal for interactive display (default 75)"; "-wrap",Arg.Set(wrap)," Do word wrapping."; "-nowrap",Arg.Clear(wrap)," Don't do word wrapping."; "-pager",Arg.Set(use_pager), " Use a pager for displaying long output in interactive mode"; "-nopager",Arg.Clear(use_pager), " Don't use a pager for displaying long output in interactive mode"; "-fields",Arg.String(fun x -> fields := !parse_fieldspec x), " \ Limit output to specified fields for the -table \ and -raw options. The optional width specifiers \ are used with the -table option, ignored otherwise. \ Use * to display all fields (but remember to escape \ the star character from your shell)."; "-borders",Arg.Set(borders), " Draw ASCII borders for tabular output. (default)"; "-noborders",Arg.Clear(borders), " Don't draw ASCII borders for tabular output."; "-ast",Arg.Set(ast), " Dump the abstract syntax tree of parsed queries to stderr."; "-debug",Arg.Set(Debug.enable), " Enable debugging information"; "-debug-level",Arg.Set_int(Debug.level), " Set debugging level (higher is more verbose, max is 100, default is 10)"; "-raise-exceptions",Arg.Set(raise_exceptions), " Don't catch exceptions. Useful with OCAMLRUNPARAM=b=1 in bytecode." ];; let specs = Arg.align (batch_specs@common_specs);; let cli_specs = Arg.align common_specs;; (* List.map (fun (x,y,z) -> (String.sub x 1 (String.length x - 1), y, z)) common_specs;; *) ara-1.0.31/httpd/0000755000000000000000000000000011553101133010341 5ustar ara-1.0.31/httpd/config.ml0000644000000000000000000000015511553072333012152 0ustar (* Config *) (* $Id$ *) module C = Configuration.Make(struct let name = "ara-httpd" end)(Opt);; include C;; ara-1.0.31/httpd/debug.mli0000644000000000000000000000016511553072333012145 0ustar val sf : ('a, unit, string) format -> 'a val level : int ref val enable : bool ref val debug : int -> string -> unit ara-1.0.31/httpd/Makefile0000644000000000000000000000044511553072333012015 0ustar # Makefile BASE = .. EXEC = ara LIBS = $(WITHTHREADS) $(WITHSTR) $(WITHUNIX) $(WITHUTIL) \ $(WITHLEDIT) $(WITHARA) $(WITHCOMMON) $(WITHCONFIGFILE) SOURCES = cache.ml config.ml debug.ml html.ml httpd.ml http.ml log.ml opt.ml process.ml rgb.ml url_encoded_form.ml include Makefile.exec ara-1.0.31/httpd/default.css0000644000000000000000000000323211553072333012510 0ustar /* $Id: default.css,v 1.10 2004/10/31 20:12:15 berke Exp $ */ /* Copyright (C) 2002 Berke Durak. All rights reserved. */ /* This stylesheet is under the GNU General Public License. */ /* This means you can use and modify it freely, but you have */ /* to credit me as your original source of inspiration. */ body { margin-left: 0.2em; background-color: #ffffff; color: #000000; font-family: helvetica, sans-serif; } ul { list-style-type: square; } h2 { font-size: 1.5em; font-family: helvetica, sans-serif; font-weight: bold; text-align: left; border-bottom-width: 0px; border-left-width: 0px; border-right-width: 0px; border-top-width: 0px; padding-left: 0px; padding-top: 0px; border-color: #000000; border-style: solid; margin-bottom: 8px; } h1 { width: 100%; border-bottom-width: 8px; border-top-width: 0px; border-left-width: 0px; border-right-width: 0px; border-style: solid; border-color: #6080f0; } div.bottom { width: 100%; border-top-width: 8px; border-bottom-width: 0px; border-left-width: 0px; border-right-width: 0px; border-style: solid; border-color: #6080f0; } div.signature { text-align: left; float: left; font-style: italic; } div.compliance { text-align: right; width: 100%; } div.query { font-family: courier, sans-serif; background-color: #ffff00; color: #000000; } div.query span.highlight { background-color: #ff0000; } a { text-decoration: underline; color: #0000ff; } a:visited { text-decoration: underline; color: #8080ff; } a:hover { color: #2030ff; background-color: #ffff00; } div.statistics { color: #808080; font-size: 0.7em; text-align:right; } ara-1.0.31/httpd/httpd.mli0000644000000000000000000000000011553072333012166 0ustar ara-1.0.31/httpd/rgb.mli0000644000000000000000000000033411553072333011627 0ustar (* Rgb *) (* $Id$ *) type t val mix : float -> t -> t -> t val add : t -> t -> t val white : t val red : t val green : t val blue : t val yellow : t val cyan : t val magenta : t val black : t val to_string : t -> string ara-1.0.31/httpd/log.ml0000644000000000000000000000327011553072333011467 0ustar (* Log *) open Unix type level = [`Debug|`Auth|`Access|`Error|`Exception|`Info];; let sf = Printf.sprintf;; let mutex = Mutex.create ();; let enable = ref true;; let file = ref "ara-httpd.log";; let timestamp () = let tm = localtime (time ()) in Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec ;; let output_channel = ref None;; let shutdown () = match !output_channel with | None -> () | Some oc -> begin try close_out oc with _ -> () end; output_channel := None ;; let init () = shutdown (); let oc = open_out_gen [Open_creat;Open_text;Open_append] 0o644 !file in output_channel := Some oc ;; let set_file fn = file := fn; init () ;; let string_of_level = function | `Debug -> "debug" | `Auth -> "auth" | `Access -> "access" | `Error -> "error" | `Exception -> "exception" | `Info -> "info" ;; let log l x = if !enable then begin let w = sf "%s %s(%02d): %s" (timestamp ()) (string_of_level l) (Thread.id (Thread.self ())) x in match !output_channel with | None -> Debug.debug 0 w | Some oc -> let w' = w^"\n" in Mutex.lock mutex; try output_string oc w'; flush oc; Mutex.unlock mutex with | x -> Mutex.unlock mutex; raise x end else () ;; let set_enable x = enable := x;; let debug = log `Debug;; let auth = log `Auth;; let access = log `Access;; let error = log `Error;; let info = log `Info;; let exc x msg = log `Exception (msg^": "^(Printexc.to_string x));; ara-1.0.31/httpd/log.mli0000644000000000000000000000065311553072333011642 0ustar (* Log *) val sf : ('a, unit, string) format -> 'a val enable : bool ref val init : unit -> unit val shutdown : unit -> unit val set_file : string -> unit val set_enable : bool -> unit val log : [`Debug|`Auth|`Access|`Error|`Exception|`Info] -> string -> unit val debug : string -> unit val auth : string -> unit val access : string -> unit val error : string -> unit val info : string -> unit val exc : exn -> string -> unit ara-1.0.31/httpd/http.mli0000644000000000000000000000077311553072333012043 0ustar val info : string -> unit type request = Get of string and headers = (string * string) list and response = Okay of content_type * byte_source | Error of error * string and error = | Internal_server_error | Document_not_found | Forbidden | Method_not_allowed and content_type = | Text_Html | Text_Css | Application_Octet_stream and byte_source = | Html of Html.html_document | File of string | String of string val handler : (request * (string * string) list -> response) -> Unix.file_descr * 'a -> unit ara-1.0.31/httpd/html.mli0000644000000000000000000000376211553072333012031 0ustar (* Html *) (* $Id$ *) val char_array_to_char_table : (char * string) array -> string option array val iso_8859_1_array : (char * string) array val iso_8859_1_table : string option array val iso_8859_1_table_sans_guillements : string option array type html_document = { head : html_head; body : html_element; } and html_head = { title : string; author : string; charset : html_charset; style_sheet : string option } and html_charset = ASCII | ISO_8859_1 | UTF8 and html_method = GET | POST and html_element = I_button of string * string | I_hidden of string * string | I_text of string * string * int option * int option | I_text_area of string * int * int * string | I_checkbox of string * string * bool | I_radio of string * string * bool | I_select of string * bool * int * (string * string * bool) list | I_reset of string | Form of html_method * string * html_element | Anchor of url * html_element | Seq of html_element list | UL of html_element list | P of html_element | H of int * html_element | T of string | BT of string | IT of string | TT of string | Pre of string | HR | Table of html_table_row list | Nop | BR | Div of string * html_element list | Span of string * html_element and html_table_row = html_table_cell list and html_table_cell = C_contents of html_element | C_halign of html_table_cell_halign * html_table_cell | C_valign of html_table_cell_valign * html_table_cell | C_rowspan of int * html_table_cell | C_colspan of int * html_table_cell | C_header of html_table_cell | C_color of Rgb.t * html_table_cell and html_table_cell_halign = Cha_left | Cha_center | Cha_right | Cha_justify | Cha_char of char and html_table_cell_valign = Cva_top | Cva_middle | Cva_bottom | Cva_baseline and url = string val output : (string -> unit) -> (char -> unit) -> html_document -> unit val output_to_channel : out_channel -> html_document -> unit val output_to_buffer : Buffer.t -> html_document -> unit val default_head : html_head ara-1.0.31/httpd/httpd.ml0000644000000000000000000000624311553072333012034 0ustar (* HTTPD *) (* $Id: httpd.ml,v 1.1.1.1 2003/12/24 07:11:11 berke Exp $ *) (* HTTP server in one module *) open Unix open Debug let info = Log.info;; let string_of_sockaddr = function | ADDR_UNIX x -> sf "UNIX(%S)" x | ADDR_INET (a, p) -> sf "%s:%d" (string_of_inet_addr a) p (*** Server *) module Server = struct let serve ~process ~port = info (sf "Listening on port %d" port); Util.wind (fun () -> let s = socket PF_INET SOCK_STREAM 0 in setsockopt s SO_REUSEADDR true; bind s (ADDR_INET (inet_addr_any, port)); listen s 256; while true do let (t,a) = accept s in info (sf "Connection from %s" (string_of_sockaddr a)); let _ = Thread.create (fun x -> try Http.handler process x with x -> info (sf "Exception (%s)" (Printexc.to_string x)); close t) (t,a) in () done) () (fun h -> Sys.set_signal Sys.sigpipe h) (Sys.signal Sys.sigpipe Sys.Signal_ignore) end (* Serve ***) (*** Make *) module Make(Dpkg : Dpkg.DB) = struct module Process = Process.Make(Dpkg) let database = new Publication.magazine;; let database_subscription = database#subscribe ();; (*** memory *) let memory () = let (miw,prw,maw) = Gc.counters () in (miw +. maw -. prw) /. 1000000.0 ;; (* ***) (*** load_database, reload_database *) let load_database ?(after = fun _ -> ()) paths = try let dbfns = Dpkg.find_database_files paths in let db' = Dpkg.load ~fast:!Opt.fast ~progress:(fun _ _ -> ()) dbfns in info (sf "Total %d packages" (Dpkg.get_count db')); database#publish `Everyone db'; after db' with | x -> info (sf "Could not load database: %s" (Printexc.to_string x)) ;; let database_paths () = let k = "ara_httpd.database.paths" in Configfile.to_list (Configfile.to_pair Configfile.to_string Configfile.to_string) ~k (Config.current#get k) ;; let reload_database () = load_database (database_paths ()) ;; (* ***) let main () = List.iter (fun (fn,ex) -> if fn <> !Opt.config_file or (!Opt.user_specified_config_file & fn = !Opt.config_file) or (match ex with Sys_error(_) -> false | _ -> true) then Printf.printf "Error loading config file %S: %s.\n" fn (Printexc.to_string ex)) (Config.load ()); load_database (database_paths ()); Server.serve ~port:!Opt.port ~process:(fun rq -> let res = ref (Http.Error(Http.Internal_server_error, "Shit")) in database_subscription#with_last_issue (fun db -> res := Process.process db rq); !res) end ;; (* ***) let _ = Arg.parse Opt.specs (fun f -> Printf.eprintf "Argument %S ignored.\n%!" f) (Sys.argv.(0) ^ " [options]"); Log.set_file !Opt.log_file; Log.info "ara-httpd started"; try if !Opt.very_slow then let module M = Make(Dpkg.DBFS) in M.main () else let module M = Make(Dpkg.DBRAM) in M.main () with | x -> Log.exc x "Exception in outer loop" ;; ara-1.0.31/httpd/cache.ml0000644000000000000000000000623111553072333011751 0ustar (* Cache *) module type S = sig type key type thing type t val create : int option -> t val find : t -> key -> thing val mem : t -> key -> bool val add : t -> key -> thing -> unit val remove : t -> key -> unit end ;; module Make(K:Map.OrderedType)(T:Map.OrderedType) = struct type key = K.t;; type thing = T.t;; type elt = { mutable priority : int; key : key; thing : thing; };; let comparator a x y = compare (a x) (a y);; let product_compare c1 c2 x y = let r = c1 x y in if r = 0 then c2 x y else r;; let compare_elements = product_compare (comparator (fun x -> x.priority)) (product_compare (fun x y -> K.compare x.key y.key) (fun x y -> T.compare x.thing y.thing)) ;; module KM = Map.Make(K);; module ES = Set.Make(struct type t = elt let compare = compare_elements end);; type t = { maximum_size : int; mutable current_size : int; mutable elements : ES.t; mutable map : elt KM.t; mutable decay_counter : int; mutable accesses : int; mutable hits : int };; let create m = { maximum_size = (match m with None -> (-1)|Some(x) -> x); current_size = 0; elements = ES.empty; map = KM.empty; decay_counter = 0; accesses = 0; hits = 0 } ;; let decay c = let l = ES.elements c.elements in List.iter (fun e -> e.priority <- e.priority / 2) l; c.elements <- List.fold_right ES.add l ES.empty ;; let statistics c = (c.accesses, c.current_size, if c.accesses > 0 then (float_of_int) c.hits /. (float_of_int) c.accesses else 0.0) ;; let find c k = c.accesses <- c.accesses + 1; let e = KM.find k c.map in c.hits <- c.hits + 1; c.elements <- ES.remove e c.elements; if e.priority < max_int then e.priority <- e.priority + 1; c.elements <- ES.add e c.elements; c.decay_counter <- c.decay_counter + 1; if c.decay_counter >= (if c.maximum_size < 0 then 2 * c.current_size else 2 * c.maximum_size) then begin c.decay_counter <- 0; decay c end; e.thing ;; let remove c k = let e = KM.find k c.map in c.elements <- ES.remove e c.elements; c.current_size <- c.current_size - 1; c.map <- KM.remove k c.map ;; let mem c k = try ignore (find c k); true with | Not_found -> false ;; let kick c = let e = ES.min_elt c.elements in c.elements <- ES.remove e c.elements; c.current_size <- c.current_size - 1; c.map <- KM.remove e.key c.map ;; let add c k t = if c.maximum_size <> 0 then begin if c.current_size = c.maximum_size then kick c; let e = { priority = (if c.current_size > 0 then (ES.max_elt c.elements).priority + 1 else 1); key = k; thing = t } in c.elements <- ES.add e c.elements; c.current_size <- c.current_size + 1; c.map <- KM.add k e c.map end ;; end ;; ara-1.0.31/httpd/opt.mli0000644000000000000000000000040311553072333011654 0ustar val port : int ref val config_file : string ref val user_specified_config_file : bool ref val dump_config : bool ref val low_memory : int ref val fast : bool ref val very_slow : bool ref val log_file : string ref val specs : (string * Arg.spec * string) list ara-1.0.31/httpd/url_encoded_form.ml0000644000000000000000000000627211553072333014221 0ustar (* Cgi *) (* $Id: cgi.ml,v 1.3 2001/02/26 20:07:07 berke Exp $ *) let sf = Printf.sprintf;; let hexadecimal c = match c with | '0' .. '9' -> (Char.code c) - (Char.code '0') | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 | 'A' .. 'F' -> (Char.code c) - (Char.code 'A') + 10 | _ -> raise (Invalid_argument (sf "Character %C is not hexadecimal" c)) ;; let read_hex_encoded_char = parser | [< 'c1; 'c2 >] -> (Char.chr (16 * (hexadecimal c1) + (hexadecimal c2))) ;; let rec read_chunk s = let b = Buffer.create 16 in let rec boucle = parser | [< 'c; s >] -> begin match c with | '%' -> Buffer.add_char b (read_hex_encoded_char s); boucle s | '+' -> Buffer.add_char b ' '; boucle s | '=' -> (Buffer.contents b, `Equal) | '&' -> (Buffer.contents b, `Ampersand) | _ -> Buffer.add_char b c; boucle s end | [< >] -> (Buffer.contents b, `EOS) in boucle s ;; module SM = Map.Make (struct type t = string let compare = compare end);; module SS = Set.Make (struct type t = string let compare = compare end);; let parse_form_from_stream t = let add n v f = if SM.mem n f then let x = SM.find n f in SM.add n (SS.add v x) f else SM.add n (SS.singleton v) f in let rec loop f = let (name,x) = read_chunk t in match x with | `EOS -> if name <> "" then raise (Invalid_argument (sf "Bad form: EOS in name %S" name)) else f | `Ampersand -> raise (Invalid_argument (sf "Bad form: ampersand in name %S" name)) | `Equal -> begin if String.length name = 0 then raise (Invalid_argument (sf "Bad form: empty name")); let (value,x) = read_chunk t in let f = add name value f in match x with | `EOS -> f | `Ampersand -> loop f | `Equal -> raise (Invalid_argument (sf "Bad form: '=' in value")) end in loop SM.empty ;; let parse_form_from_string s = let t = Stream.of_string s in parse_form_from_stream t ;; let display_stringmapstring f = SM.iter (fun k d -> Printf.printf "\"%s\" -> \"%s\"\n" k d) f ;; let display_stringsetstringmap f = SM.iter (fun k d -> Printf.printf "\"%s\" -> {" k; SS.iter (fun s -> Printf.printf " \"%s\"" s) d; Printf.printf " }\n") f ;; let encode_string b x = let hex = "0123456789ABCDEF" in for i = 0 to String.length x - 1 do let c = x.[i] in let d = Char.code c in if c = ' ' then Buffer.add_char b '+' else if d < 32 or d > 126 or c = '&' or c = '=' or c = '"' or c = '%' then begin Buffer.add_char b '%'; Buffer.add_char b hex.[d lsr 4]; Buffer.add_char b hex.[d land 15]; end else Buffer.add_char b c done ;; let encode_form f = let b = Buffer.create 16 in SM.iter (fun n s -> (SS.iter (fun v -> if Buffer.length b > 0 then Buffer.add_char b '&'; encode_string b n; Buffer.add_char b '='; encode_string b v) s)) f; Buffer.contents b ;; let encode_form_from_list f = let b = Buffer.create 16 in List.iter (fun (n,s) -> (List.iter (fun v -> if Buffer.length b > 0 then Buffer.add_char b '&'; encode_string b n; Buffer.add_char b '='; encode_string b v) s)) f; Buffer.contents b ;; ara-1.0.31/httpd/url_encoded_form.mli0000644000000000000000000000367611553072333014377 0ustar val sf : ('a, unit, string) format -> 'a val hexadecimal : char -> int val read_hex_encoded_char : char Stream.t -> char val read_chunk : char Stream.t -> string * [> `Ampersand | `EOS | `Equal ] module SM : sig type key = string type +'a t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module SS : sig type elt = string type t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t end val parse_form_from_stream : char Stream.t -> SS.t SM.t val parse_form_from_string : string -> SS.t SM.t val display_stringmapstring : string SM.t -> unit val display_stringsetstringmap : SS.t SM.t -> unit val encode_string : Buffer.t -> string -> unit val encode_form : SS.t SM.t -> string val encode_form_from_list : (string * string list) list -> string ara-1.0.31/httpd/cache.mli0000644000000000000000000000132211553072333012116 0ustar (* Cache *) module type S = sig type key and thing and t val create : int option -> t val find : t -> key -> thing val mem : t -> key -> bool val add : t -> key -> thing -> unit val remove : t -> key -> unit end ;; module Make : functor (K : Map.OrderedType) -> functor (T : Map.OrderedType) -> sig type key = K.t and thing = T.t type t val create : int option -> t val decay : t -> unit val statistics : t -> int * int * float val find : t -> key -> thing val remove : t -> key -> unit val mem : t -> key -> bool val kick : t -> unit val add : t -> key -> thing -> unit end ;; ara-1.0.31/httpd/debug.ml0000644000000000000000000000060611553072333011774 0ustar (* Debug *) (* $Id: debug.ml,v 1.2 2004/10/24 20:27:24 berke Exp $ *) let sf = Printf.sprintf;; let mutex = Mutex.create ();; let level = ref 0;; let enable = ref false;; let debug l x = if !enable && l >= !level then begin Mutex.lock mutex; Printf.eprintf "debug(%03d,%05d): %s\n%!" l (Thread.id (Thread.self ())) x; Mutex.unlock mutex end else () ;; ara-1.0.31/httpd/rgb.ml0000644000000000000000000000135711553072333011464 0ustar (* Rgb *) (* $Id: rgb.ml,v 1.3 2001/03/06 19:14:00 berke Exp $ *) (* Gestion sommaire de l'espace colorimétrique Rouge-Vert-Bleu *) type t = float * float * float let mix alpha (r1,g1,b1) (r2,g2,b2) = let f x y = (1.0 -. alpha) *. x +. alpha *. y in (f r1 r2, f g1 g2, f b1 b2) let add (r1,g1,b1) (r2,g2,b2) = let g x = if x > 1.0 then 1.0 else x in let f x y = g (x +. y) in (f r1 r2, f g1 g2, f b1 b2) let white = (1.0,1.0,1.0) let red = (1.0,0.0,0.0) let green = (0.0,1.0,0.0) let blue = (0.0,0.0,1.0) let yellow = add red green let cyan = add green blue let magenta = add red blue let black = (0.0,0.0,0.0) let to_string (r,g,b) = let f x = int_of_float (255.0 *. x) in Printf.sprintf "#%02x%02x%02x" (f r) (f g) (f b) ara-1.0.31/httpd/config.mli0000644000000000000000000000075111553072333012325 0ustar module C : sig val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list end val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list ara-1.0.31/httpd/opt.ml0000644000000000000000000000200011553072333011476 0ustar (* Opt *) (* $Id: opt.ml,v 1.1 2004/10/26 09:44:54 berke Exp $ *) let config_file = ref "ara-httpd.config";; let user_specified_config_file = ref false;; let dump_config = ref false;; let low_memory = ref 131072;; (* KiB *) let fast = ref false;; let very_slow = ref (Util.proc_get_free_mem () < !low_memory);; let port = ref 9999;; let log_file = ref "ara-httpd.log";; let specs = [ "-port",Arg.Set_int(port), " Set TCP port for receiving HTTP requests (default 9999)."; "-log-file",Arg.Set_string(log_file), " Set log file (default ara-httpd.log)"; "-fast",Arg.Clear(very_slow), " Run faster but use more memory."; "-slow",Arg.Set(very_slow), " Use minimal amount of memory but run very slowly."; "-cache-strings",Arg.Clear(fast), " With -fast, try to conserve memory somewhat."; "-debug",Arg.Set(Debug.enable), " Enable debugging information"; "-debug-level",Arg.Set_int(Debug.level), " Set debugging level (higher is more verbose, max is 100, default is 10)"; ] ;; ara-1.0.31/httpd/html.ml0000644000000000000000000002656411553072333011665 0ustar (* Html *) (* $Id: html.ml,v 1.8 2001/03/06 19:13:59 berke Exp $ *) (* Petit module de output HTML *) (* par Berke Durak *) (* 20001104 *) let sf = Printf.sprintf;; let char_array_to_char_table a = let b = Array.make 256 None in for i = 0 to Array.length a - 1 do let (c,s) = a.(i) in b.(Char.code c) <- Some ("&"^s^";") done; b ;; (* Ce tableau de conversion a été engendré avec la commande *) (* zcat /usr/doc/doc-rfc/all-included-rfcs/rfc1866.txt.gz | perl -e 'while(){if(/^\<\!ENTITY\s+(\w+)\s+CDATA\s+\"\&\#(\d+)\;/){printf " \047\\%03d\047, \"$1\"\;\n",$2}}' *) (* Découlant directement des Tes Sacrés, il ne peut contenir d'erreur. *) (*** iso_8859_1_array *) let iso_8859_1_array = [| '\038', "amp"; '\062', "gt"; '\060', "lt"; '\034', "quot"; '\198', "AElig"; '\193', "Aacute"; '\194', "Acirc"; '\192', "Agrave"; '\197', "Aring"; '\195', "Atilde"; '\196', "Auml"; '\199', "Ccedil"; '\208', "ETH"; '\201', "Eacute"; '\202', "Ecirc"; '\200', "Egrave"; '\203', "Euml"; '\205', "Iacute"; '\206', "Icirc"; '\204', "Igrave"; '\207', "Iuml"; '\209', "Ntilde"; '\211', "Oacute"; '\212', "Ocirc"; '\210', "Ograve"; '\216', "Oslash"; '\213', "Otilde"; '\214', "Ouml"; '\222', "THORN"; '\218', "Uacute"; '\219', "Ucirc"; '\217', "Ugrave"; '\220', "Uuml"; '\221', "Yacute"; '\225', "aacute"; '\226', "acirc"; '\230', "aelig"; '\224', "agrave"; '\229', "aring"; '\227', "atilde"; '\228', "auml"; '\231', "ccedil"; '\233', "eacute"; '\234', "ecirc"; '\232', "egrave"; '\240', "eth"; '\235', "euml"; '\237', "iacute"; '\238', "icirc"; '\236', "igrave"; '\239', "iuml"; '\241', "ntilde"; '\243', "oacute"; '\244', "ocirc"; '\242', "ograve"; '\248', "oslash"; '\245', "otilde"; '\246', "ouml"; '\223', "szlig"; '\254', "thorn"; '\250', "uacute"; '\251', "ucirc"; '\249', "ugrave"; '\252', "uuml"; '\253', "yacute"; '\255', "yuml"; |];; (* ***) let iso_8859_1_table = char_array_to_char_table iso_8859_1_array let iso_8859_1_table_sans_guillements = let a = Array.copy iso_8859_1_table in a.(Char.code '"') <- Some """; a ;; let iso_8859_1_table_nl_to_br = let a = Array.copy iso_8859_1_table in a.(Char.code '\n') <- Some "
\n"; a ;; type html_document = { head: html_head; body: html_element } and html_head = { title: string; author: string; charset: html_charset; style_sheet: string option } and html_charset = ASCII | ISO_8859_1 | UTF8 and html_method = GET | POST and html_element = | I_button of string * string (* name, value *) | I_hidden of string * string | I_text of string * string * int option * int option (* name, value, size, maxlength *) | I_text_area of string * int * int * string | I_checkbox of string * string * bool | I_radio of string * string * bool | I_select of string * bool * int * (string * string * bool) list | I_reset of string | Form of html_method * string * html_element | Anchor of url * html_element | Seq of html_element list | UL of html_element list | P of html_element | H of int * html_element | T of string (* ISO-8859-1 text *) | BT of string (* ISO-8859-1 text *) | IT of string (* ISO-8859-1 text *) | TT of string (* ISO-8859-1 text *) | Pre of string (* pre-formatted text *) | HR | Table of html_table_row list | Nop | BR | Div of string * html_element list | Span of string * html_element and html_table_row = html_table_cell list and html_table_cell = | C_contents of html_element | C_halign of html_table_cell_halign * html_table_cell | C_valign of html_table_cell_valign * html_table_cell | C_rowspan of int * html_table_cell | C_colspan of int * html_table_cell | C_header of html_table_cell | C_color of Rgb.t * html_table_cell and html_table_cell_halign = | Cha_left | Cha_center | Cha_right | Cha_justify | Cha_char of char and html_table_cell_valign = | Cva_top | Cva_middle | Cva_bottom | Cva_baseline and url = string ;; let default_head = { title = "Untitled"; author = "Ara HTTPD"; charset = ISO_8859_1; style_sheet = None } ;; let string_of_charset = function | ASCII -> "ascii" | ISO_8859_1 -> "iso-8859-1" | UTF8 -> "utf8" ;; let output (f : string -> unit) (fc : char -> unit) x = let indent = ref 0 in let put_indent () = for i = 1 to !indent do f " " done in let text_avec_table t y = for i = 0 to String.length y - 1 do let c = y.[i] in match t.(Char.code c) with | None -> fc c | Some u -> f u done in let text = text_avec_table iso_8859_1_table and text_without_quotes = text_avec_table iso_8859_1_table_sans_guillements in let gui = text_without_quotes in let ife f = function | Some x -> ignore (f x) | None -> () in let launch_tag x = put_indent (); f ("<"^x) and flush_tag () = f ">\n"; incr indent and flush_linear_tag () = f ">\n" and flush_tag_without_nl () = f ">"; and end_tag x = decr indent; put_indent (); f ("\n") and end_tag_linear x = f ("\n") in let start_tag x = launch_tag x; flush_tag () and start_tag_lineaire x = launch_tag x; flush_linear_tag () and start_tag_without_nl x = launch_tag x; flush_tag_without_nl () in let linear_tag x = launch_tag x; flush_linear_tag () in let rec cellule c i j = let rec loop he ha va rs cs rgb c = match c with | C_header (c) -> loop true ha va rs cs rgb c | C_halign (ha,c) -> loop he (Some ha) va rs cs rgb c | C_valign (va,c) -> loop he ha (Some va) rs cs rgb c | C_rowspan (rs,c) -> loop he ha va (Some rs) cs rgb c | C_colspan (cs,c) -> loop he ha va rs (Some cs) rgb c | C_color (rgb,c) -> loop he ha va rs cs (Some rgb) c | C_contents e -> launch_tag (if he then "TH" else "TD"); begin let coefficient_parity_row = -2 and coefficient_parity_column = -1 and coefficient_head = -4 and shift = 11 and coefficient_total = 12 in match rgb with Some(rgb) -> f (Printf.sprintf " BGCOLOR=\"%s\"" (Rgb.to_string (let alpha = (float_of_int (((if he then 0 else coefficient_head) + coefficient_parity_row * (i mod 2) + coefficient_parity_column * (j mod 2)) + shift)) /. (float_of_int coefficient_total) in Rgb.mix alpha Rgb.white rgb))); | _ -> () end; ife (fun ha -> f " ALIGN="; match ha with | Cha_left -> f "LEFT" | Cha_center -> f "CENTER" | Cha_right -> f "RIGHT" | Cha_justify -> f "JUSTIFY" | Cha_char c -> f "\""; gui (String.make 1 c); f "\"") ha; ife (fun va -> f " VALIGN="; match va with | Cva_top -> f "TOP" | Cva_middle -> f "MIDDLE" | Cva_bottom -> f "BOTTOM" | Cva_baseline -> f "BASELINE") va; ife (fun rs -> f (" ROWSPAN="^(string_of_int rs))) rs; ife (fun cs -> f (" COLSPAN="^(string_of_int cs))) cs; flush_tag (); element e; end_tag (if he then "TH" else "TD") in loop false None None None None None c and element y = match y with | Anchor(u,e) -> launch_tag "A"; f " HREF=\""; gui u; f "\""; flush_tag (); element e; end_tag "A" | Form (m,u,e) -> launch_tag "FORM"; f (" METHOD="^(match m with POST -> "POST" | GET -> "GET")^" ACTION=\""); f u; f "\" ENCTYPE=\"application/x-www-form-urlencoded\""; flush_tag (); element e; end_tag "FORM"; | Div(c, z) -> launch_tag "DIV"; f (sf " CLASS=%S" c); flush_tag (); List.iter (fun t -> element t) z; end_tag "DIV" | Span(c, z) -> launch_tag "SPAN"; f (sf " CLASS=%S" c); flush_tag (); element z; end_tag "SPAN" | Seq z -> List.iter (fun t -> element t) z | UL l -> start_tag "UL"; List.iter (fun t -> start_tag "LI"; element t; end_tag "LI") l; end_tag "UL" | H(i, z) -> start_tag ("H"^(string_of_int i)); element z; end_tag ("H"^(string_of_int i)) | T z -> put_indent (); text_avec_table iso_8859_1_table_nl_to_br z; f "\n" | BT z -> start_tag "B"; text z; end_tag "B" | TT z -> start_tag "TT"; text z; end_tag "TT" | IT z -> start_tag "I"; text z; end_tag "I" | Pre z -> start_tag_without_nl "PRE"; text z; end_tag_linear "PRE" | HR -> linear_tag "HR" | BR -> linear_tag "BR" | P z -> linear_tag "P"; element z (* start_tag "P"; element z; end_tag "P" *) | Nop -> f " " | I_select (n,m,s,l) -> launch_tag "SELECT"; f " SIZE="; f (string_of_int s); f " NAME=\""; gui n; f (if m then "\" MULTIPLE" else "\""); flush_tag (); List.iter (fun (n,v,s) -> launch_tag "OPTION"; f " VALUE=\""; gui n; f (if s then "\" SELECTED" else "\""); flush_linear_tag (); text v; f " ") l; end_tag "SELECT" | I_reset (v) -> launch_tag "INPUT"; f " TYPE=RESET VALUE=\""; gui v; f "\""; flush_linear_tag () | I_button (n,v) -> launch_tag "INPUT"; f " TYPE=SUBMIT NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\""; flush_linear_tag () | I_hidden (n,v) -> launch_tag "INPUT"; f " TYPE=HIDDEN NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\""; flush_linear_tag () | I_text (n,v,s,m) -> launch_tag "INPUT"; f " TYPE=TEXT NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\""; begin match s with | Some(s) -> f (" SIZE="^(string_of_int s)) | None -> (); end; begin match m with | Some(m) -> f (" MAXLENGTH="^(string_of_int m)) | None -> (); end; flush_linear_tag () | I_text_area (n,r,c,v) -> launch_tag "TEXTAREA"; f (Printf.sprintf " ROWS=%d COLS=%d NAME=\"" r c); gui n; f "\""; flush_linear_tag (); text v; end_tag_linear "TEXTAREA" | I_checkbox (n,v,c) -> launch_tag "INPUT"; f " TYPE=CHECKBOX NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\""; if c then f " CHECKED"; flush_linear_tag (); | I_radio (n,v,c) -> launch_tag "INPUT"; f " TYPE=RADIO NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\""; if c then f " CHECKED"; flush_linear_tag (); | Table l -> start_tag "TABLE"; let (i,j) = (ref 0, ref 0) in List.iter (fun r -> start_tag "TR"; j := 0; List.iter (fun r' -> cellule r' !i !j; incr j) r; incr i; end_tag "TR") l; end_tag "TABLE" in begin f "\n"; start_tag "HTML"; begin start_tag "HEAD"; (* title *) begin start_tag_without_nl "TITLE"; text x.head.title; end_tag_linear "TITLE"; (* css *) begin match x.head.style_sheet with | None -> () | Some css -> launch_tag "LINK"; f " REL=\"stylesheet\" TYPE=\"text/css\" HREF=\""; text_without_quotes css; f "\""; flush_linear_tag () end; (* meta *) begin launch_tag "META"; f (sf " HTTP-EQUIV=\"Content-Type: text/html; charset=%s\"" (string_of_charset x.head.charset)); flush_linear_tag (); launch_tag "META"; f " NAME=\"Author\" CONTENT=\""; text_without_quotes x.head.author; f "\""; flush_linear_tag () end; end; end_tag "HEAD"; end; (* body *) begin start_tag "BODY"; element x.body; end_tag "BODY"; end; end_tag "HTML"; end ;; let output_to_channel oc = output (output_string oc) (output_char oc);; let output_to_buffer b x = output (Buffer.add_string b) (Buffer.add_char b) x;; ara-1.0.31/httpd/process.ml0000644000000000000000000002765611553072333012402 0ustar (* Process *) module Make(Dpkg : Dpkg.DB) = struct module Ara = Ara.Make(Dpkg);; module UEF = Url_encoded_form;; open Html;; open Debug;; open Dpkg;; open Ara;; module C = Cache.Make(String)(struct type t = Dpkg.IS.u let compare = compare end);; let info = Log.info;; let cache = C.create (Some 1024);; let identity x = x;; exception Value_not_unique of string;; let get_unique_value ~(converter : string -> 'a) ?(default : 'a option) ky vr = try let s = UEF.SM.find ky vr in if UEF.SS.cardinal s = 1 then converter (UEF.SS.choose s) else raise (Value_not_unique ky) with | Not_found -> match default with | None -> raise Not_found | Some d -> d ;; let plural x = if x = 1 then "" else "s";; exception No_variables_allowed of string;; exception Variable_not_found of string;; let compression_buffer = Dpkg.IS.create_compression_buffer ();; (*** eval *) let eval db q w = let x = try Dpkg.IS.decompress compression_buffer (C.find cache w) with | Not_found -> let x = Ara.eval_statement db ~get:(fun id -> raise (Variable_not_found id)) ~set:(fun id -> raise (No_variables_allowed id)) (* XXX *) q in C.add cache w (Dpkg.IS.compress compression_buffer x); x in Ara.sorted_list_of_query db x (*Ara.compute_query db ~get:(fun id -> raise (Variable_not_found id)) ~set:(fun id -> raise (No_variables_allowed id)) (* XXX *) q*) ;; (* ***) let default_field_order = ["Package"],["Description"];; (*** compute_fields *) let compute_fields ?(field_order=default_field_order) db = let (pre_fields, post_fields) = field_order in let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in let pre_fields = convert pre_fields and post_fields = convert post_fields in let fields = get_fields db in let rec other i r = if i = Array.length fields then r else other (i + 1) (if List.mem i pre_fields or List.mem i post_fields then r else i::r) in let other_fields = other 0 [] in (pre_fields, other_fields, post_fields) ;; (* ***) let ara_head title = { default_head with title = title; author = "Ara HTTP Daemon by Oguz Berke Durak"; charset = ISO_8859_1; style_sheet = Some("/stylesheet") } ;; let builtin_style_sheet = "\ body { font-family: helvetica, sans-serif; }\n\ div.query { font-family: courier, sans-serif; \n\ background-color: #ffff00;\n\ color: #000000; }\n\ div.query span.highlight { background-color: #ff0000; }\n\ ";; let style_sheet () = try Http.File(Config.current#get_string "ara_httpd.interface.stylesheet") with | Not_found -> Http.String(builtin_style_sheet) ;; let process db = function | Http.Get x,hdrs -> let x = Util.delete_first_chars 1 x in (* fishy *) let (path,args) = Util.split_once_at ((=) '?') x in info (sf "Path=%S args=%S" path args); let vars = UEF.parse_form_from_string args in match path with | "stylesheet" -> Http.Okay(Http.Text_Css, style_sheet ()) | "show" -> let i = get_unique_value ~converter:int_of_string "package" vars in let (pre_fields, other_fields, post_fields) = compute_fields db in let p = Dpkg.get_package db i in let title = sf "Package information for %s (%s)" (Dpkg.name_of db i) (Dpkg.version_of db i); in let pf = new Dpkg.paragraph_folder in Http.Okay(Http.Text_Html, Http.Html { head = ara_head title; body = Seq[ H(1,T(title)); P( Table( [C_color(Rgb.red, C_header(C_contents(T "Field"))); C_color(Rgb.green, C_header(C_contents(T "Contents")))]:: (let dn = Dpkg.get_display_names db in List.fold_left (fun r j -> let x = Dpkg.get_field db i j in if x = "" then r else begin pf#reset; pf#add_string x; let y = pf#get in [C_color(Rgb.red, C_contents(T dn.(j))); C_color(Rgb.green, C_contents(T y))]::r end) [] (List.rev (pre_fields@other_fields@post_fields)))))] }) | "search" -> let result,query = try let w = get_unique_value ~converter:identity "query" vars in let m = String.length w in try let q = statement_of_string w in let xl = eval db q w in let xlc = Ara.filter_old_versions db xl in let lxl = List.length xl and lxlc = List.length xlc in let per_page = 15 in let start = get_unique_value ~converter:int_of_string ~default:0 "start" vars and stop = get_unique_value ~converter:int_of_string ~default:(min lxl (per_page - 1)) "stop" vars in let start = max 0 start in let stop = min (max start (min (start + per_page - 1) stop)) (lxl - 1) in let xl = Util.list_sub_rev xl start stop in let navig = P(Seq[ Anchor("search?"^ (UEF.encode_form_from_list ["query", [w]; "start", [sf "%d" (start-per_page)]; "stop", [sf "%d" (start-1)]]), T "<< Prev <<"); Anchor("search?"^ (UEF.encode_form_from_list ["query", [w]; "start", [sf "%d" (start+per_page)]; "stop", [sf "%d" (start+2 * per_page-1)]]), T ">> Next >>")]) in Seq[ P(T(sf "Total %d package%s (and %d version%s). Showing %d to %d." lxlc (plural lxlc) lxl (plural lxl) start stop)); navig; P( Table( [C_color(Rgb.red, C_header(C_contents(T "Package"))); C_color(Rgb.green, C_header(C_contents(T "Version"))); C_color(Rgb.yellow, C_header(C_contents(T "Description")))]:: (let df = Dpkg.field_of_string db "description" in List.fold_left (fun r i -> let p = Dpkg.name_of db i in let v = Dpkg.version_of db i in let des = Dpkg.get_field db i df in [C_color(Rgb.red, C_contents( Anchor("show?"^(UEF.encode_form_from_list ["package",[sf "%d" i]]), T p))); C_color(Rgb.green, C_contents(T v)); C_color(Rgb.yellow, C_contents(T (Util.first_line des)))]::r) [] xl))); navig],w with | Parse_error(i,j,x) -> P( if i = j then if i >= m - 1 then Seq[T "There is a parse error at the end of your query."; Div("query",[ P(Seq[T w; Span("highlight", T "?")])])] else Seq[T (sf "There is a parse error at character %d in your query: %s." (i + 1) x); Div("query",[ P(Seq[ if i > 0 then T(String.sub w 0 (min (m - 1) i)) else Nop; if i < m then Span("highlight", T(String.sub w i 1)) else Nop; if i + 1 < m then T(String.sub w (j + 1) (m - j - 1)) else Nop])])] else begin Seq[T (sf "There is a parse error between characters %d and %d in your query: %s." (i + 1) (j + 1) x); Div("query", [P(Seq[ if i > 0 then T(String.sub w 0 (min (m - 1) i)) else Nop; if i < m then Span("highlight", T(String.sub w i ((min (m - 1) j) - i + 1))) else Nop; if j + 1 < m then T(String.sub w (j + 1) (m - j - 1)) else Nop])])] end),w | x -> P(T(sf "Error: %s." (Printexc.to_string x))),w with | Not_found -> P(T "Please type your query."),"tetris & section=games" in let doc = { head = ara_head "Search Debian packages using Ara"; body = Seq[ H(1,T("Search Debian packages using ara")); (*P(T("Hello. You just suck. Motherfucker !")); P(Seq[T("You just said: "); Table( [[C_color(Rgb.red, C_header(C_contents(T "Key"))); C_color(Rgb.green, C_header(C_contents(T "Value")))]]@ (Url_encoded_form.SM.fold (fun k v r -> Url_encoded_form.SS.fold (fun v r -> [C_color(Rgb.red, C_contents(T k)); C_color(Rgb.green, C_contents(T v))]::r) v r) vars [])); Pre(x)]); *) result; Form(GET, "search", P(Seq[ I_button("action", "Search"); I_reset("Clear"); BR; I_text_area("query",4,80,query)])); P(Seq[T "For help on the syntax, please read the "; Anchor("http://ara.alioth.debian.org/ara.html", T "manual page"); T "."; BR; T "You can also get the stand-alone CLI or GTK2 versions "; Anchor("http://ara.alioth.debian.org/", T "ara or xara"); T "."]); Div("statistics",[ P(T( let (accesses,size,ratio) = C.statistics cache in sf "Total %d accesses, cache size %d, hit ratio %.3f." accesses size ratio))]); ] } in Http.Okay(Http.Text_Html, Http.Html doc) | "compact" -> let (rsz1,vsz1) = Util.proc_get_rsz_vsz () in Gc.compact (); let (rsz2,vsz2) = Util.proc_get_rsz_vsz () in Http.Okay(Http.Text_Html, Http.Html { head = ara_head "Mother fucking piece of shit"; body = Seq[ H(1,T("Memory compaction")); P(T(sf "Compaction saved %d resident and %d virtual pages.\n Currently, %d resident and %d virtual pages are used." (rsz1 - rsz2) (vsz1 - vsz2) rsz2 vsz2))] }) | "shit" -> let doc = { head = ara_head "Mother fucking piece of shit"; body = Seq[ H(1,T("Are you stupid ?")); P(T("Hello. You just suck. Motherfucker !"))] } in Http.Okay(Http.Text_Html, Http.Html doc) | x -> Http.Error(Http.Document_not_found,x) ;; end ;; ara-1.0.31/httpd/process.mli0000644000000000000000000000017611553072333012537 0ustar module Make : functor (Dpkg : Dpkg.DB) -> sig val process : Dpkg.db -> Http.request * 'a -> Http.response end ara-1.0.31/httpd/http.ml0000644000000000000000000001430511553072333011666 0ustar (*** HTTP *) open Unix;; open Debug;; let info = Log.info;; type request = | Get of string and headers = (string * string) list and response = | Okay of content_type * byte_source | Error of error * string and error = | Internal_server_error | Document_not_found | Forbidden | Method_not_allowed and content_type = | Text_Html | Text_Css | Application_Octet_stream and byte_source = | Html of Html.html_document | File of string | String of string ;; let string_of_content_type = function | Text_Html -> "text/html" | Text_Css -> "text/css" | Application_Octet_stream -> "application/octet-stream" ;; open Html;; let error_document err str = let code,title,msg = match err with | Internal_server_error -> 500, "Internal server error", sf "The server encountered and internal error (%s)\ and was unable to complete your request." str | Method_not_allowed -> 405, "Method not allowed", sf "The method (%S) is not allowed." str | Document_not_found -> 404, "Not found", sf "The document you requested (%S) could not be \ located." str | Forbidden -> 403, "Forbidden", sf "You are not allowed to access %S." str in code, title, { head = { default_head with title = title; author = "ARA HTTP Server"; charset = ISO_8859_1 }; body = Seq[ H(1,T(title)); P(T msg)] } ;; let handler processor (fd,address) = let ic = in_channel_of_descr fd and oc = out_channel_of_descr fd and b = Buffer.create 16 in let rec loop () = let (meth,url,vh,vl) = Scanf.sscanf (input_line ic) "%s %s HTTP/%d.%d\r" (fun meth url vh vl -> (meth,url,vh,vl)) in let rec collect_headers r = match input_line ic with | "\r" -> r | l -> collect_headers ((Scanf.sscanf l "%s@: %s@\r" (fun f v -> (String.lowercase f,v)))::r) in let hdrs = collect_headers [] in List.iter (fun (x,y) -> Log.access (sf "Header: %s %S" x y)) hdrs; let keep_alive = try String.lowercase (List.assoc "connection" hdrs) = "keep-alive" (* XXX *) with | Not_found -> false in let connection_string = if keep_alive then "Keep-Alive" else "Close" in let output_html rh ct d = Html.output_to_buffer b d; Printf.fprintf oc "%s\r\n" rh; if ct = Text_Html then Printf.fprintf oc "Content-Type: text/html; charset=iso-8859-1\r\n" (* XXX *) else Printf.fprintf oc "Content-Type: %s\r\n" (string_of_content_type ct); Printf.fprintf oc "\ Content-Length: %d\r\n\ Connection: %s\r\n\ \r\n" (Buffer.length b) connection_string; Buffer.output_buffer oc b; Buffer.clear b; flush oc in let do_error err str = let code,title,doc = error_document err str in Log.access (sf "ERROR %S %S" str title); output_html (sf "HTTP/1.1 %d %s" code title) Text_Html doc (* shutdown fd SHUTDOWN_ALL *) in begin match meth with | "GET" -> begin let result = try processor (Get url,hdrs) with | x -> Error(Internal_server_error, sf "An exception occurred: %s" (Printexc.to_string x)) in let custom ct bs = match bs with | Html d -> output_html "HTTP/1.1 200 Fine" ct d; Log.access (sf "OK GET %S html" url) | String w -> Printf.fprintf oc "HTTP/1.1 200 Fine\r\n\ Content-Type: %s\r\n\ Connection: %s\r\n\ Content-Length: %d\r\n\ \r\n" (string_of_content_type ct) connection_string (String.length w); output_string oc w; flush oc; Log.access (sf "OK GET %S string" url) | File fn -> begin try let ic = open_in fn in let m = 4096 in let b = Buffer.create m in let w = String.make m '\000' in try while true do let n = input ic w 0 m in if n = 0 then raise End_of_file else Buffer.add_substring b w 0 n done; assert false with | End_of_file -> close_in ic; Printf.fprintf oc "HTTP/1.1 200 Fine\r\n\ Content-Type: %s\r\n\ Connection: %s\r\n\ Content-Length: %d\r\n\ \r\n" (string_of_content_type ct) connection_string (Buffer.length b); Buffer.output_buffer oc b; flush oc; Log.access (sf "OK GET %S file %S" url fn) with | x -> do_error Internal_server_error (Printexc.to_string x) end in match result with | Okay(ct,bs) -> custom ct bs (* shutdown fd SHUTDOWN_ALL *) | Error(err,str) -> do_error err str end | _ -> do_error Method_not_allowed meth end; if keep_alive then loop () else begin shutdown fd SHUTDOWN_ALL; close_out oc; Log.access "Closing connection"; Thread.exit () end in try loop () with | End_of_file -> info "Remote end closed connection"; shutdown fd SHUTDOWN_ALL; close_out oc; Thread.exit () ;; ara-1.0.31/configfile/0000755000000000000000000000000011553101133011323 5ustar ara-1.0.31/configfile/Makefile0000644000000000000000000000025311553072340012772 0ustar # $Id$ BASE = .. LIB = configfile LIBS =$(WITHUNIX) SOURCES = configfile.ml configurator.ml \ oldconfig.ml configuration.ml PP = -pp camlp4o include Makefile.library ara-1.0.31/configfile/configurator.ml0000644000000000000000000000420611553072340014370 0ustar (* Configurator *) (* $Id: config.ml,v 1.5 2004/10/26 09:44:54 berke Exp $ *) module CF = Configfile;; let home_directory = Sys.getenv "HOME";; let directory_in_home x = Filename.concat home_directory ("."^x);; class configurator ?(defaults=[]) ?(directory=home_directory) ?(primary_file=Filename.concat home_directory ".something.config") () = object(self) val mutable defaults = defaults val mutable directory = directory val mutable primary = Some primary_file val mutable context = CF.create_context (Some primary_file) method set_defaults x = defaults <- x method set_directory x = directory <- x method path str = Filename.concat directory str method ensure_directory_presence = if not (Sys.file_exists directory) then Unix.mkdir directory 0o755 method set_primary x = primary <- Some(x); CF.set_filename context primary method load ?(merge_with=[]) () = let (cx,ex) = CF.load ~merge_with primary defaults in context <- cx; ex method load_defaults = let (cx,ex) = CF.load None defaults in if ex = [] then context <- cx; ex method save = self#ensure_directory_presence; CF.save context method set_config t = CF.set_config context t method set_context ctx = context <- ctx method context = context (*method touch = CF.touch context*) method set k v = CF.set context k v method get ?default k = CF.get ?default context k method get_int ?default k = CF.get_int ?default context k method get_string ?default k = CF.get_string ?default context k method get_bool ?default k = CF.get_bool ?default context k method get_string_pair k = CF.get_pair (CF.to_string ~k) (CF.to_string ~k) context k method set_string_pair k (x,y) = CF.set_pair context k (CF.String x, CF.String y) method set_int k x = CF.set_int context k x method set_string k x = CF.set_string context k x method set_bool k x = CF.set_bool context k x end ;; let duplicate (c : configurator) : configurator = let c' = Oo.copy c in c'#set_context (Configfile.duplicate_context c'#context); c' ;; ara-1.0.31/configfile/configuration.ml0000644000000000000000000000545711553072340014546 0ustar (* Config *) (* $Id$ *) module type BASE = sig val name : string end ;; module type OPT = sig val config_file : string ref val user_specified_config_file : bool ref end ;; module Make(B:BASE)(Opt:OPT) = struct let home = Sys.getenv "HOME" let directory = Filename.concat home ".ara" let primary_file () = let x = !Opt.config_file in let x = if not !Opt.user_specified_config_file && Filename.is_relative x then Filename.concat directory x else x in Opt.config_file := x; x let current = new Configurator.configurator ~defaults:["/etc/"^(B.name)^".config"] ~directory ~primary_file:(primary_file ()) () ;; module Convert = struct open Configfile;; open Oldconfig;; let convert cfg = Record(ref [B.name,handle (Record(ref [ "database", handle (Record(ref [ "paths", handle (List(List.map (fun (x,y) -> Tuple[String x; String y]) cfg.database_paths))])); "commands", let ri = "/etc/alternatives/x-terminal-emulator -e /usr/bin/sudo " in handle (Record(ref [ "run_interactive", handle (String("${COMMAND}")); "dist_upgrade", handle (String( (if B.name = "ara" then ri else "")^"/usr/bin/apt-get dist-upgrade")); "upgrade", handle (String( (if B.name = "ara" then ri else "")^"/usr/bin/apt-get upgrade")); "install", handle (String(cfg.install_cmd)); "update", handle (String(cfg.update_cmd)); "remove", handle (String(cfg.remove_cmd)); "print", handle (String(cfg.print_cmd)); "pager", handle (String(cfg.pager_cmd))]))]))]) ;; end ;; let load () = let pf = primary_file () in current#set_primary pf; let converted = ref false in let tl = try Oldconfig.load Oldconfig.current pf; converted := true; [Convert.convert Oldconfig.current] with | Sys_error(x) -> if !Opt.user_specified_config_file then begin Printf.eprintf "Could not load configuration file: %s.\n" x; exit 1 end else [] | f -> [] in let l = current#load ~merge_with:tl () in if !converted && not !Opt.user_specified_config_file then begin Printf.printf "Converted older configuration file.\n%!"; current#save; List.filter (fun (fn,_) -> fn <> pf) l end else l ;; end ;; ara-1.0.31/configfile/configfile.mli0000644000000000000000000000366111553072340014150 0ustar (* Configfile *) (* $Id$ *) type t = | List of t list | Boolean of bool | Integer of int | String of string | Tuple of t list | Record of (string * handle) list ref and handle and status = | Dont_change (* don't save to user configuration file *) | Save (* should be saved when other values are saved *) | Changed (* was changed, needs saving *) ;; type context;; exception Parse_error of int * string exception Semantic_error of string exception Key_not_found of string exception No_default_value of string exception Is_not_a_record of string exception Type_error of string * string exception No_filename;; val handle : t -> handle val create_context : ?config:t option -> string option -> context val get_config : context -> t val set_config : context -> t -> unit val load_from_file : string -> t val load : ?merge_with:t list -> string option -> string list -> context * (string * exn) list val save : context -> unit val get : ?set:bool -> ?default:t -> context -> string -> t val set : context -> string -> t -> unit val to_int : ?k:string -> t -> int val to_string : ?k:string -> t -> string val to_bool : ?k:string -> t -> bool val to_pair : (t -> 'a) -> (t -> 'b) -> ?k:string -> t -> 'a * 'b val to_list : (t -> 'a) -> ?k:string -> t -> 'a list val get_int : ?default:int -> context -> string -> int val get_string : ?default:string -> context -> string -> string val get_bool : ?default:bool -> context -> string -> bool val get_pair : ?default:t -> (t -> 'a) -> (t -> 'b) -> context -> string -> 'a * 'b val get_list : ?default:t -> (t -> 'a) -> context -> string -> 'a list val set_int : context -> string -> int -> unit val set_string : context -> string -> string -> unit val set_bool : context -> string -> bool -> unit val set_pair : context -> string -> t * t -> unit val dump : ?show_status:bool -> Format.formatter -> t -> unit val duplicate : t -> t val duplicate_context : context -> context val set_filename : context -> string option -> unit ara-1.0.31/configfile/configuration.mli0000644000000000000000000000077411553072340014714 0ustar module type BASE = sig val name : string end module type OPT = sig val config_file : string ref val user_specified_config_file : bool ref end module Make : functor (B : BASE) -> functor (Opt : OPT) -> sig val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list end ara-1.0.31/configfile/configfile.ml0000644000000000000000000004215711553072340014002 0ustar (* Configuration *) (* $Id$ *) type t = | List of t list | Boolean of bool | Integer of int | String of string | Tuple of t list | Record of (string * handle) list ref and handle = { mutable status : status; mutable value : t } and status = | Dont_change (* don't save to user configuration file *) | Save (* should be saved when other values are saved *) | Changed (* was changed, needs saving *) ;; type context = { mutable filename : string option; cache : (string, t) Hashtbl.t; config : handle };; let handle v = { status = Dont_change; value = v };; (*** comment_killer_line_counter *) let comment_killer_line_counter lc s = let rec state0 = parser | [< 'c; s >] -> (match c with | '#' -> state1 s | '\n' -> incr lc; [< 'c; state0 s >] | _ -> [< 'c; state0 s >]) | [< >] -> [< >] and state1 = parser | [< 'c; s >] -> if c = '\n' then begin incr lc; [< '' '; state0 s >] end else state1 s | [< >] -> [< >] in state0 s ;; (* ***) let keywords = [".";"{";"}";"(";")";"[";"]";",";";";":";"true";"false";"on";"off";"yes";"no"];; (*** parse_config *) let parse_config s = (* parses record contents. string * handle list *) let rec parse_record ?(toplevel=false) r = parser | [< '(Genlex.Ident k); h = parse_record2; s >] -> parse_record ~toplevel ((k,h)::r) s | [< '(Genlex.Kwd "}") >] -> if toplevel then raise Stream.Failure else r | [< >] -> if toplevel then r else raise Stream.Failure (* returns a handle *) and parse_record2 = parser | [< '(Genlex.Kwd ":"); v = parse_stuff2 >] -> handle v | [< '(Genlex.Kwd "{"); hl = parse_record [] >] -> handle (Record(ref hl)) | [< '(Genlex.Kwd "."); '(Genlex.Ident k); h = parse_record2 >] -> handle (Record(ref [k,h])) (* returns a t *) and parse_stuff2 = parser | [< '(Genlex.Kwd "{"); hl = parse_record [] >] -> Record(ref hl) | [< '(Genlex.Int i) >] -> Integer i | [< '(Genlex.Kwd ("true"|"on"|"yes")) >] -> Boolean true | [< '(Genlex.Kwd ("false"|"off"|"no")) >] -> Boolean false | [< '(Genlex.String w) >] -> String w | [< '(Genlex.Kwd "("); x = parse_tuple [] >] -> Tuple(x) | [< '(Genlex.Kwd "["); x = parse_list [] >] -> List(x) and parse_tuple l = parser | [< x = parse_stuff2; s >] -> parse_tuple2 (x::l) s | [< >] -> parse_tuple2 l s and parse_tuple2 l = parser | [< '(Genlex.Kwd ")") >] -> List.rev l | [< '(Genlex.Kwd ","); s >] -> parse_tuple l s and parse_list l = parser | [< x = parse_stuff2; s >] -> parse_list2 (x::l) s | [< >] -> parse_list2 l s and parse_list2 l = parser | [< '(Genlex.Kwd "]") >] -> List.rev l | [< '(Genlex.Kwd ";"); s >] -> parse_list l s in parse_record ~toplevel:true [] s ;; (* ***) exception Parse_error of int * string;; exception Semantic_error of string;; exception Key_not_found of string;; exception No_default_value of string;; exception Is_not_a_record of string;; exception Type_error of string * string;; exception No_filename;; (*** create_context *) let create_context ?(config = None) fn = let t = match config with None -> Record(ref []) | Some t -> t in { filename = fn; cache = Hashtbl.create 16; config = handle t } ;; (* ***) (*** iter_over_keys *) let iter_over_keys f t = let rec loop ks = function | Tuple _|List _|Boolean _|Integer _|String _ -> f ks | Record(lr) -> List.iter (fun (k,h) -> loop (k::ks) h.value) !lr in loop [] t ;; (* ***) (*** change_status_all *) let change_status_all f t = let rec loop = function | Record(lr) -> List.iter (fun (k,h) -> h.status <- f h.status; loop h.value) !lr | (Tuple l|List l) -> List.iter loop l | Boolean _|Integer _|String _ -> () in loop t;; (* ***) (*** needs_saving *) let rec needs_saving = function | Record(lr) -> List.exists (fun (k,h) -> h.status <> Dont_change or needs_saving h.value) !lr | (Tuple l|List l) -> List.exists needs_saving l | Boolean _|Integer _|String _ -> false ;; (* ***) (*** filter_changed *) let filter_changed ctx t = let rec loop ks r = function | (k,h)::u -> if h.status <> Dont_change or needs_saving h.value then begin match h.value with | Tuple _|List _|Boolean _|Integer _|String _ -> loop ks ((k,h)::r) u | Record(lr) -> if List.exists (fun (_,h) -> h.status <> Dont_change or needs_saving h.value) !lr then loop ks ((k,{ status = h.status; value = loop (k::ks) [] !lr})::r) u else loop ks r u end else loop ks r u | [] -> Record(ref r) in match ctx.config.value with | Record(lr) -> loop [] [] !lr | t -> t ;; (* ***) (*** get_config *) let get_config ctx = ctx.config.value;; (* ***) (*** set_config *) let set_config ctx t = ctx.config.value <- t; ctx.config.status <- Changed; Hashtbl.clear ctx.cache ;; (* ***) (*** coalesce *) let coalesce ?(merge=false) t = let rec coalesce path = function | List(l) -> List(List.map (coalesce path) l) | (Boolean _|Integer _|String _) as x -> x | Tuple(l) -> Tuple(List.map (coalesce path) l) | Record(lr) -> let l = !lr in let rec loop r = function | (k,h)::y -> let v = coalesce (k::path) h.value in if List.mem_assoc k r then begin let h' = List.assoc k r in let (s,v) = match (v, h'.value) with (*| List(l1),List(l2) -> Dont_change,List(l1@l2)*) | Record(lr1),Record(lr2) -> (Dont_change,coalesce (k::path) (Record(ref ((!lr1)@(!lr2))))) (* ? *) | _ -> if merge then match h.status,h'.status with | ((Save|Changed),Dont_change) -> (Changed, h.value) | (Dont_change,(Save|Changed)) -> (Changed, h'.value) | (Dont_change,Dont_change) -> (Changed, h'.value) | _ -> raise (Semantic_error (Printf.sprintf "Cannot join changed values for key %s under %s" k (String.concat "." path))) else raise (Semantic_error (Printf.sprintf "Cannot join values for key %s under %s" k (String.concat "." path))) in loop ((k, {status = s; value = v})::(List.remove_assoc k r)) y end else loop ((k,h)::r) y | [] -> Record(ref r) in loop [] l in coalesce [] t ;; (* ***) (*** parse_string *) let parse_string w = let ts = (Genlex.make_lexer keywords) (Stream.of_string w) in parse_config ts ;; (* ***) (*** dump *) let dump ?(show_status=false) f t = let rec loop ?(top=false) = function | List(l) -> Format.fprintf f "[@["; let y = ref false in List.iter (fun x -> if !y then Format.fprintf f ";@ "; loop x; y := true) l; Format.fprintf f "@]]" | Tuple(l) -> Format.fprintf f "(@["; let y = ref false in List.iter (fun x -> if !y then Format.fprintf f ",@ "; loop x; y := true) l; Format.fprintf f "@])" | Boolean true -> Format.fprintf f "true" | Boolean false -> Format.fprintf f "false" | String w -> Format.fprintf f "%S" w | Integer x -> Format.fprintf f "%d" x | Record lr -> let l = !lr in if not top then Format.fprintf f "{@["; let y = ref false in List.iter (fun (k,h) -> let x = h.value in if not top or !y & top then Format.fprintf f "@\n"; y := true; if show_status then Format.fprintf f "(* %s *) " (match h.status with | Dont_change -> "Don't change" | Save -> "Save" | Changed -> "Changed") else (); begin match x with | Record(_) -> Format.fprintf f "%s " k; | _ -> Format.fprintf f "%s: " k; end; loop x) l; if not top then Format.fprintf f "@]@\n}" in loop ~top:true t ;; (* ***) (*** load_from_file *) let load_from_file fn = let ic = open_in fn in let lc = ref 1 in let ts = (Genlex.make_lexer keywords) (comment_killer_line_counter lc (Stream.of_channel ic)) in let pe x = close_in ic; raise (Parse_error(!lc,x)) in try let t = parse_config ts in close_in ic; coalesce (Record(ref t)) with | Parsing.Parse_error -> pe "Lexical error" | (Stream.Error(_)|Stream.Failure) -> pe "Syntax error" ;; (* ***) (*** load *) let load ?(merge_with=[]) primary_fn default_fns = let errors = ref [] in let res = ref (List.map (fun x -> ("root",handle x)) merge_with) in List.iter (fun fn -> try let t = load_from_file fn in let h = if Some fn = primary_fn then begin change_status_all (fun _ -> Save) t; { status = Save; value = t } end else { status = Dont_change; value = t } in (*Format.printf ">>> From file %S:\n" fn; dump ~show_status:true Format.std_formatter t;*) res := ("root",h)::!res with | x -> errors := (fn,x)::!errors) (match primary_fn with None -> default_fns | Some fn -> fn::default_fns); let t = match coalesce ~merge:true (Record(res)) with | Record(lr) -> begin match !lr with | [_,h] -> h.value | [] -> Record(ref []) | _ -> assert false end | _ -> assert false in ({ filename = primary_fn; cache = Hashtbl.create 16; config = handle t }, !errors) ;; (* ***) (*** split_at_dots *) let split_at_dots u = let m = String.length u in let rec loop r i j = if i >= m then List.rev r else if j = m or u.[j] = '.' then loop ((String.sub u i (j - i))::r) (j + 1) (j + 1) else loop r i (j + 1) in loop [] 0 0 ;; (* ***) (*** access *) let access ?(set = false) ?default ctx k = try (* First, check if the value is already in cache (except if set is true). *) if set then raise Not_found else Hashtbl.find ctx.cache k with | Not_found -> (* Value is notin cache, we'll have to dig it up. *) let ks = split_at_dots k in (* Split the key into components *) (* loop h kl searches and eventually creates or updates the value named kl * in h, which msut be a handle to a record *) let rec loop (h : handle) kl = match kl with | [] -> (* An empty selector selects the current handle * whose value is returned, or changed *) if set then (* We must change the value *) match default with | None -> raise (No_default_value(k)) | Some t -> (* Compare the stored and actual values *) if h.value <> t then begin h.status <- Changed; h.value <- t; Hashtbl.remove ctx.cache k; (* invalidate cache entry *) t end else begin (* Return the value stored in the cell. *) h.value end else h.value | k1::ks -> (* The selector is not empty. We must first select k1 in h * and then proceed. *) match h.value with | Record(lr) -> (* All right, we are accessing a record ; k1 should be a member of it. *) begin let l = !lr in match (* Try to get the handle for k1 in the record. *) try Some(List.assoc k1 l) with | Not_found -> None with | Some h' -> (* We have found the handle for k1. *) (* Recursively call loop on it. *) loop h' ks | None -> (* Handle for k1 not found in current record. * We'll need to create it. *) match default with | None -> (* There is no default. What are we supposed to write ?? *) raise (Key_not_found k) | Some t' -> begin (* The value of this handle, or one of its subhandles * will be changed. Therefore we set the status of this * handle to Changed. *) h.status <- Changed; if ks = [] then begin (* This is the penultimate handle. * In other words h is the handle * of the record that will contain * the value to be changed. *) lr := (k1,{ status = Changed; value = t' })::!lr; t' end else begin (* This is not yet the penultimate handle. * In other words we still need to create * subsrecords. *) let h'' = { status = Changed; value = Record(ref []) } in lr := (k1,h'')::!lr; loop h'' ks end end end | _ -> dump Format.std_formatter ctx.config.value; raise (Is_not_a_record k) in loop ctx.config ks ;; (* ***) (*** get, set, to_*, get_*, set_* *) let get = access;; let set ctx k (x : t) = ignore (access ~set:true ?default:(Some x) ctx k);; let to_int ?(k="") = function Integer i -> i | _ -> raise (Type_error(k,"Integer"));; let to_string ?(k="") = function String w -> w | _ -> raise (Type_error(k,"String"));; let to_bool ?(k="") = function Boolean x -> x | _ -> raise (Type_error(k,"Boolean"));; let to_pair f g ?(k="") = function Tuple[x;y] -> (f x, g y) | _ -> raise (Type_error(k,"Pair"));; let to_list f ?(k="") = function List l -> List.map f l | _ -> raise (Type_error(k,"List"));; let ( <~< ) f (g : ?k:'a -> 'b -> 'c) ?default ctx k = g ~k (f ?default ctx k);; let get_int ?default ctx k = to_int ~k (get ?default:(match default with None -> None | Some i -> Some(Integer i)) ctx k);; let get_bool ?default ctx k = to_bool ~k (get ?default:(match default with None -> None | Some x -> Some(Boolean x)) ctx k);; let get_string ?default ctx k = to_string ~k (get ?default:(match default with None -> None | Some w -> Some(String w)) ctx k);; let get_list ?default f ctx k = to_list f ~k (get ?default ctx k);; let get_pair ?default f g ctx k = to_pair f g ~k (get ?default ctx k);; let set_int ctx k i = set ctx k (Integer i);; let set_string ctx k w = set ctx k (String w);; let set_bool ctx k x = set ctx k (Boolean x);; let set_pair ctx k (x, y) = set ctx k (Tuple[x;y]);; (* ***) (*** duplicate *) let rec duplicate = function | Record(lr) -> Record(ref (List.map (fun (k,h) -> (k,{ h with value = duplicate h.value })) !lr)) | List(l) -> List(List.map duplicate l) | Tuple(l) -> Tuple(List.map duplicate l) | (String _ | Integer _ | Boolean _) as x -> x ;; (* ***) (*** duplicate_context *) let duplicate_context ctx = let h = handle (duplicate ctx.config.value) in h.status <- ctx.config.status; { ctx with cache = Hashtbl.create 16; config = h } ;; (* ***) (*** save *) let save ctx = match ctx.filename with | None -> raise No_filename | Some filename -> if true or ctx.config.status <> Dont_change then begin let oc = open_out filename in try let l = Unix.localtime (Unix.gettimeofday ()) in Printf.fprintf oc "(* %S written on %04d-%02d-%02d %02d:%02d:%02d *)\n" filename (l.Unix.tm_year + 1900) (l.Unix.tm_mon + 1) l.Unix.tm_mday l.Unix.tm_hour l.Unix.tm_min l.Unix.tm_sec; Printf.fprintf oc "(* Configuration values are preserved but formatting and comments\n \ will be lost on next write. *)\n"; let t = filter_changed ctx ctx.config in let f = Format.formatter_of_out_channel oc in dump f t; Format.pp_print_flush f (); close_out oc; change_status_all (function Changed|Save -> Save | Dont_change -> Dont_change) ctx.config.value; with | x -> close_out oc; raise x end else () ;; (* ***) (*** set_filename *) let set_filename ctx f = ctx.filename <- f;; (* ***) ara-1.0.31/configfile/oldconfig.ml0000644000000000000000000000733311553072340013636 0ustar (* Config *) (* $Id: config.ml,v 1.5 2004/10/26 09:44:54 berke Exp $ *) type t = { mutable database_paths : (string * string) list; mutable install_cmd : string; mutable remove_cmd : string; mutable update_cmd : string; mutable print_cmd : string; mutable pager_cmd : string } ;; let gui_default = { database_paths = [("/var/lib/apt/lists/","_Packages$");("/var/lib/dpkg/","^status$")]; install_cmd = "/etc/alternatives/x-terminal-emulator -e /usr/bin/sudo /usr/bin/apt-get install ${PACKAGE}=${VERSION}"; remove_cmd = "/etc/alternatives/x-terminal-emulator -e /usr/bin/sudo /usr/bin/apt-get remove ${PACKAGE}=${VERSION}"; update_cmd = "/etc/alternatives/x-terminal-emulator -e /usr/bin/sudo /usr/bin/apt-get update"; print_cmd = "/usr/bin/a2ps -q"; pager_cmd = "/etc/alternatives/pager" } ;; let cli_default = { database_paths = [("/var/lib/apt/lists/","_Packages$");("/var/lib/dpkg/","^status$")]; install_cmd = "/usr/bin/sudo /usr/bin/apt-get install ${PACKAGE}=${VERSION}"; remove_cmd = "/usr/bin/sudo /usr/bin/apt-get remove ${PACKAGE}=${VERSION}"; update_cmd = "/usr/bin/sudo /usr/bin/apt-get update"; print_cmd = "/usr/bin/a2ps"; pager_cmd = "/etc/alternatives/pager" } ;; let duplicate x = { x with update_cmd = x.update_cmd };; let overwrite x y = y.database_paths <- x.database_paths; y.install_cmd <- x.install_cmd; y.remove_cmd <- x.remove_cmd; y.update_cmd <- x.update_cmd; y.print_cmd <- x.print_cmd; y.pager_cmd <- x.pager_cmd ;; let current = duplicate gui_default;; let fp = Printf.fprintf;; let directory = Filename.concat (Sys.getenv "HOME") ".ara";; let path str = Filename.concat directory str;; let ensure_directory_presence () = if not (Sys.file_exists directory) then Unix.mkdir directory 0o755 ;; let save cfg fn = ensure_directory_presence (); let oc = open_out fn in fp oc "database_paths"; List.iter (fun (x,y) -> fp oc " path %S %S" x y) cfg.database_paths; fp oc " end\n"; fp oc "install_cmd %S\n" cfg.install_cmd; fp oc "remove_cmd %S\n" cfg.remove_cmd; fp oc "update_cmd %S\n" cfg.update_cmd; fp oc "print_cmd %S\n" cfg.print_cmd; fp oc "pager_cmd %S\n" cfg.pager_cmd; close_out oc ;; exception Invalid_configuration_file of string;; let load cfg fn = let sb = Scanf.Scanning.from_file fn in try while true do Scanf.bscanf sb " %[a-z0-9_] " (function | "database_paths" -> let rec loop pth = Scanf.bscanf sb " %s" (function | "path" -> Scanf.bscanf sb " %S %S" (fun x y -> loop ((x,y)::pth)) (* not tail rec *) | "end" -> (* Debug.debug 10 (Debug.sf "database_paths [%s]" (String.concat ";" (List.map (fun (x,y) -> Printf.sprintf "%S,%S" x y) pth))); *) cfg.database_paths <- pth | _ -> raise (Invalid_configuration_file (Printf.sprintf "Error in database path specification in file %S" fn))) in loop [] | "install_cmd" -> Scanf.bscanf sb "%S" (fun x -> cfg.install_cmd <- x) | "remove_cmd" -> Scanf.bscanf sb "%S" (fun x -> cfg.remove_cmd <- x) | "update_cmd" -> Scanf.bscanf sb "%S" (fun x -> cfg.update_cmd <- x) | "print_cmd" -> Scanf.bscanf sb "%S" (fun x -> cfg.print_cmd <- x) | "pager_cmd" -> Scanf.bscanf sb "%S" (fun x -> cfg.pager_cmd <- x) | x -> if x = "" && Scanf.Scanning.end_of_input sb then raise End_of_file (* Scanf bug (?) workaround *) else raise (Invalid_configuration_file (Printf.sprintf "Unexpected token %S in file %S" x fn))) done with | End_of_file -> () ;; ara-1.0.31/configfile/oldconfig.mli0000644000000000000000000000112211553072340013775 0ustar type t = { mutable database_paths : (string * string) list; mutable install_cmd : string; mutable remove_cmd : string; mutable update_cmd : string; mutable print_cmd : string; mutable pager_cmd : string; } val gui_default : t val cli_default : t val duplicate : t -> t val overwrite : t -> t -> unit val current : t val fp : out_channel -> ('a, out_channel, unit) format -> 'a val directory : string val path : string -> string val ensure_directory_presence : unit -> unit val save : t -> string -> unit exception Invalid_configuration_file of string val load : t -> string -> unit ara-1.0.31/configfile/configurator.mli0000644000000000000000000000261511553072340014543 0ustar val home_directory : string val directory_in_home : string -> string class configurator : ?defaults:string list -> ?directory:string -> ?primary_file:string -> unit -> object val mutable context : Configfile.context val mutable defaults : string list val mutable directory : string val mutable primary : string option method context : Configfile.context method ensure_directory_presence : unit method get : ?default:Configfile.t -> string -> Configfile.t method get_bool : ?default:bool -> string -> bool method get_int : ?default:int -> string -> int method get_string : ?default:string -> string -> string method get_string_pair : string -> string * string method load : ?merge_with:Configfile.t list -> unit -> (string * exn) list method load_defaults : (string * exn) list method path : string -> string method save : unit method set : string -> Configfile.t -> unit method set_bool : string -> bool -> unit method set_config : Configfile.t -> unit method set_context : Configfile.context -> unit method set_defaults : string list -> unit method set_directory : string -> unit method set_int : string -> int -> unit method set_primary : string -> unit method set_string : string -> string -> unit method set_string_pair : string -> string * string -> unit end val duplicate : configurator -> configurator ara-1.0.31/configfile/test.config0000644000000000000000000000133111553072340013476 0ustar zorgol: "pipi" special: true gui { windows { syntax_help { height: 30 width: 2000 } main { height: 50 width: 20 } } } commands { pager: "/etc/alternatives/pager" print: "/usr/bin/a2ps shit" update: "/usr/bin/sudo /usr/bin/apt-get update" remove: "/usr/bin/sudo /usr/bin/apt-get remove ${PACKAGE}=${VERSION}" install: "/usr/bin/sudo /usr/bin/apt-get install ${PACKAGE}=${VERSION}" } database_paths { path: [("/var/lib/apt/lists", "_Package$"); ("/var/lib/apt/lists", "^status$")] }ara-1.0.31/Makefile0000644000000000000000000000323211553072340010665 0ustar # $Id: Makefile,v 1.8 2004/10/26 09:44:54 berke Exp $ MAKE := $(MAKE) -I ../config all: native doc bt: byte doc doc: @$(MAKE) -C doc native: depend @(for x in $(MODULES); do \ $(MAKE) -C $$x || exit 1; \ done) depend: @(for x in $(MODULES); do \ $(MAKE) -C $$x depend || exit 1; \ done) byte: depend @(for x in $(MODULES); do \ $(MAKE) -C $$x bt || exit 1; \ done) httpd: depend $(MAKE) -C httpd httpd-byte: depend $(MAKE) -C httpd bt MODULES = util configfile ledit libara common cli gui DIRS = $(MODULES) doc httpd .PHONY: $(DIRS) all bt native byte doc depend httpd-byte \ install install_bt install_natives install_bytes install_indep clean: @(for x in $(DIRS); do \ $(MAKE) -C $$x clean; \ done); \ rm -f *-stamp DESTDIR = install_natives: all mkdir -p $(DESTDIR)/usr/bin install -m 755 cli/ara $(DESTDIR)/usr/bin/ara install -m 755 gui/xara $(DESTDIR)/usr/bin/xara install_bytes: bt mkdir -p $(DESTDIR)/usr/bin install -m 755 cli/ara.bt $(DESTDIR)/usr/bin/ara install -m 755 gui/xara.bt $(DESTDIR)/usr/bin/xara install_indep: mkdir -p $(DESTDIR)/etc $(DESTDIR)/usr/share/man/man1 install -m 644 doc/ara.1 $(DESTDIR)/usr/share/man/man1/ gzip -9 $(DESTDIR)/usr/share/man/man1/ara.1 install -m 644 etc/ara.config $(DESTDIR)/etc/ara.config install -m 644 doc/xara.1 $(DESTDIR)/usr/share/man/man1/ gzip -9 $(DESTDIR)/usr/share/man/man1/xara.1 install -m 644 etc/xara.config $(DESTDIR)/etc/xara.config install -m 644 etc/xara-gtkrc-2.0 $(DESTDIR)/etc/xara-gtkrc-2.0 install: install_natives install_indep install_bt: install_bytes install_indep ara-1.0.31/libara/0000755000000000000000000000000011553101133010450 5ustar ara-1.0.31/libara/Makefile0000644000000000000000000000051711553072337012130 0ustar # $Id: Makefile.ara,v 1.1 2004/10/26 09:44:54 berke Exp $ BASE = .. LIB = ara LIBS = $(WITHSTR) $(WITHUNIX) $(WITHUTIL) SOURCES = ast.ml syntax.mly lexic.mli lexic.mll slurp.ml debver.mli debver.ml \ virtual_strings.mli virtual_strings.ml rle.ml dpkg.ml ara.ml EXTRA_CLEAN = syntax.ml syntax.mli lexic.ml include Makefile.library ara-1.0.31/libara/virtual_strings.ml0000644000000000000000000000620111553072337014255 0ustar (* Virtual_strings *) (* $Id$ *) type file = { name : string; fd : Unix.file_descr; mtime : float; mutable mtime_counter : int; range_low : int; range_high : int } and pool = { mutable count : int; mutable files : file array; mutable high : int } and virtual_string = { beginning : int; length : int } and t = Real of string | Virtual of virtual_string;; exception Error of string;; exception Not_real;; exception File_out_of_date of string;; let sf = Printf.sprintf;; let create () = { count = 0; files = [||]; high = 0 };; let add_file p name fd = let st = Unix.fstat fd in let a = p.files in p.files <- Array.init (p.count + 1) (fun i -> if i < p.count then a.(i) else { name = name; fd = fd; mtime = st.Unix.st_mtime; mtime_counter = 0; range_low = p.high; range_high = p.high + st.Unix.st_size - 1 }); p.count <- 1 + p.count; p.high <- p.high + st.Unix.st_size; p.count - 1 ;; (*** find_file *) let find_file p o = let a = p.files in let m = Array.length a in let rec loop i0 m = if m = 0 then raise Not_found else begin if m < 8 then if a.(i0).range_low <= o && o <= a.(i0).range_high then i0 else loop (i0 + 1) (m - 1) else let i = i0 + m / 2 in if a.(i).range_low <= o then if o <= a.(i).range_high then i else loop (i + 1) (m - m / 2) else loop i0 (m / 2) end in loop 0 m ;; (* ***) let make_virtual_string p f o m = if m = 0 then Real "" else Virtual{ beginning = p.files.(f).range_low + o; length = m } ;; let empty_string = Real "";; let is_empty = function | Real "" -> true | _ -> false ;; let make_real_string s = Real(s) ;; let rec get_real_string p = function | Real(u) -> u | Virtual(_) -> raise Not_real ;; let check_mtime_every = ref 100;; let mtime_counter = ref 0;; (*** get_string *) let rec get_string p = function | Real(u) -> u | Virtual(s) -> let f = find_file p s.beginning in assert (p.files.(f).range_low <= s.beginning && s.beginning <= p.files.(f).range_high); let o = s.beginning - p.files.(f).range_low in try (* XXX *) let fl = p.files.(f) in fl.mtime_counter <- 1 + fl.mtime_counter; if fl.mtime_counter >= !check_mtime_every then begin fl.mtime_counter <- 0; let st = Unix.fstat fl.fd in if st.Unix.st_mtime > fl.mtime then raise (File_out_of_date fl.name); end; ignore (Unix.lseek fl.fd o Unix.SEEK_SET); let u = String.create s.length in if s.length <> Unix.read fl.fd u 0 s.length then raise (Error(sf "Read error in file %S" fl.name)) else u with | File_out_of_date _ as x -> raise x | x -> raise (Error(sf "Error in file %S offsets %d+%d (%d): %s" p.files.(f).name o s.beginning s.length (Printexc.to_string x))) ;; (* ***) ara-1.0.31/libara/slurp.mli0000644000000000000000000000033511553072336012335 0ustar type entry = File of string * file_info | Directory of string * entry list | Error of string * exn and file_info = { file_size : int; } val with_chdir_to : string -> (unit -> 'a) -> 'a val slurp : string -> entry ara-1.0.31/libara/rle.ml0000644000000000000000000000614511553072337011607 0ustar (* RLE *) type t = string;; exception Invalid_compressed_data of string;; let decompress b u = Buffer.clear b; let m = String.length u in let rec loop1 x s i = if i = m then raise (Invalid_compressed_data "EOF in integer"); let y = Char.code u.[i] in if y < 128 then ((y lsl s) lor x, i + 1) else loop1 (((y land 127) lsl s) lor x) (s + 7) (i + 1) and loop2 i = if i = m then begin let u = Buffer.contents b in Buffer.clear b; u end else let (x,i) = loop1 0 0 i in if x land 1 = 0 then (* walk *) begin let x = x lsr 1 in if i + x > m then raise (Invalid_compressed_data "Walk too long"); Buffer.add_substring b u i x; loop2 (i + x) end else (* run *) begin let x = x lsr 1 in if i >= m then raise (Invalid_compressed_data "Run too long"); Buffer.add_string b (String.make x u.[i]); loop2 (i + 1) end in loop2 0 ;; let emit_int b x = let add_byte y = Buffer.add_char b (Char.chr y) in if x < 128 then add_byte x else if x < 16384 then begin add_byte (128 lor (x land 127)); add_byte (x lsr 7); end else if x < 2097152 then begin add_byte (128 lor (x land 127)); add_byte (128 lor ((x lsr 7) land 127)); add_byte ((x lsr 14) land 127) end else (* should be enough *) begin add_byte (128 lor (x land 127)); add_byte (128 lor ((x lsr 7) land 127)); add_byte (128 lor ((x lsr 14) land 127)); add_byte ((x lsr 21) land 127) end ;; let compress b u = Buffer.clear b; let m = String.length u in let count_run i = let rec loop q c j = if j = m or u.[j] <> q then c else loop q (c + 1) (j + 1) in loop u.[i] 1 (i + 1) in let emit_run c q = if c > 0 then begin emit_int b (1 lor (c lsl 1)); Buffer.add_char b q end in let emit_walk i j = let n = j - i in if n > 0 then begin emit_int b (n lsl 1); Buffer.add_substring b u i n end in let finish i = if i < m then emit_walk i m; let u = Buffer.contents b in Buffer.clear b; u in (* bytes starting from i have not yet been emitted *) (* we are examining byte j *) let rec walk i j = if j = m then finish i else let c = count_run j in if c < 8 then walk i (j + c) else begin emit_walk i j; emit_run c u.[j]; walk (j + c) (j + c) end in walk 0 0 ;; let test fn = let ic = open_in fn in let b = Buffer.create 16 in try let i = ref 0 in while true do let u = input_line ic in incr i; try let u' = compress b u in let u'' = decompress b u' in if u <> u'' then begin Printf.printf "FAILURE line %d: %S <> %S\n" !i u u'' end with | x -> Printf.printf "EXCEPTION line %d: %S %s\n" !i u (Printexc.to_string x) done; assert false with | End_of_file -> close_in ic ;; ara-1.0.31/libara/ast.mli0000644000000000000000000000253111553072337011760 0ustar (* AST *) (* $Id: ast.mli,v 1.3 2004/07/25 20:40:23 berke Exp $ *) (* AST *) (* $Id: ast.mli,v 1.3 2004/07/25 20:40:23 berke Exp $ *) type ident = string type ('a,'b) boolean = | And of ('a,'b) boolean * ('a,'b) boolean | Or of ('a,'b) boolean * ('a,'b) boolean | Not of ('a,'b) boolean | True | False | Atom of 'a | Meta of 'b * ('a,'b) boolean and 'a relational = | Identity | Union of 'a relational * 'a relational | Intersection of 'a relational * 'a relational | Complement of 'a relational | Star of 'a relational | Plus of 'a relational | Compose of 'a relational * 'a relational | Reverse of 'a relational | Relation of 'a type regexp_option = | Case_insensitive | Word_boundary type statement = | Assign of ident * int * int * set_query | Display of set_query and relation = | Field_link of field_spec and atomic_set = | Matches of field_spec * pattern | Reference of ident and pattern = | Exact of string | Lexicographic_le of string | Lexicographic_lt of string | Lexicographic_ge of string | Lexicographic_gt of string | Regular of string * regexp_option list and field_spec = | Current_field | Some_field of pattern | This_field of string | Either_field of field_spec * field_spec and meta = | With_field of field_spec | Apply_relation of relation relational and set_query = (atomic_set, meta) boolean val dump : Format.formatter -> statement -> unit ara-1.0.31/libara/dpkg.mli.disabled0000644000000000000000000002624711553072337013676 0ustar module SS : sig type t = string * string val compare : 'a -> 'a -> int end module SSM : sig type key = SS.t type 'a t = 'a Map.Make(SS).t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module IM : sig type key = int type +'a t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module type BIG_SET = sig type t type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list end module type SMALL_SET = sig type t type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list val shift : int val mask : int end module type LENGTH_PARAM = sig val shift : int val mask : int val count : int end module Set64 : SMALL_SET module Arrayified_small_set : functor (S : SMALL_SET) -> functor (L : LENGTH_PARAM) -> SMALL_SET module Mapified_set : functor (S : SMALL_SET) -> BIG_SET module ASS64 : sig type t type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list val shift : int val mask : int end module IS : sig type t = Mapified_set(ASS64).t type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list end module SM : sig type key = String.t type 'a t = 'a Map.Make(String).t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module SSet : sig type elt = String.t type t = Set.Make(String).t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t end module type STRINGSTUFF = sig type s end module type DB = sig module IS : BIG_SET type db and field val field_of_string : db -> string -> int val string_of_field : db -> int -> string val display_name_of_field : db -> int -> string val display_string_of_field : db -> int -> string val name_of : db -> int -> string val version_of : db -> int -> string val key_of : db -> int -> string * string val find_package : db -> string -> string -> int val get_package : db -> int -> string array val get_field : db -> int -> int -> string exception Malformed_line of string val find_database_files : (string * string) list -> string list val load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> db val get_universe : db -> IS.t val get_fields : db -> string array val get_count : db -> int val get_display_names : db -> string array val package_field : db -> int val version_field : db -> int end module Virtual_strings : sig type file = { name : string; fd : Unix.file_descr; mtime : float; range_low : int; range_high : int; } and pool = { mutable count : int; mutable files : file array; mutable high : int; } and virtual_string = { beginning : int; length : int; } and t = | Real of string | Virtual of virtual_string exception Error of string exception Not_real val sf : ('a, unit, string) format -> 'a val create : unit -> pool val add_file : pool -> string -> Unix.file_descr -> int val find_file : pool -> int -> int val make_virtual_string : pool -> int -> int -> int -> t val is_empty : t -> bool val make_real_string : string -> t val get_real_string : 'a -> t -> string val get_string : pool -> t -> string end module DB_FS : DB module DB_GEN : functor (S : STRINGSTUFF) -> sig module IS : sig type t = Mapified_set(ASS64).t type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list end type db = { m : int; db : field array array; fields : string array; display_names : string array; package_field : int; version_field : int; index : int SSM.t; universe : IS.t; } and field = string type load_context = { field_index : (string, int) Hashtbl.t; non_canonical_names : (string, string) Hashtbl.t; mutable field_count : int; read_buffer : Buffer.t; mutable package_count : int; mutable packages : (int * string) list list; shared_strings : (string, string) Hashtbl.t; } val hashtable_overhead : int val create_load_context : unit -> load_context val binary_search : 'a array -> 'a -> int val field_of_string : db -> string -> int val string_of_field : db -> int -> string val display_name_of_field : db -> int -> string val display_string_of_field : db -> int -> string val name_of : db -> int -> field val version_of : db -> int -> field val key_of : db -> int -> field * field val find_package : db -> string -> string -> int val get_package : db -> int -> field array val get_field : db -> int -> int -> field val get_field_from_package : 'a -> 'b array -> int -> 'b val get_universe : db -> IS.t val get_fields : db -> string array val get_count : db -> int val get_display_names : db -> string array val package_field : db -> int val version_field : db -> int exception Malformed_line of string val decompose_line : string -> string * string val first_non_space : string -> int val read_tags : fast:bool -> load_context -> in_channel -> (int * string) list val load_single_file : fast:bool -> ?progress:(string -> int -> unit) -> load_context -> string -> unit val flip_array : 'a array -> unit val collect_field_values : db -> int -> SSet.elt list val find_database_files : (string * string) list -> string list val load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> db end module DB_RAM : sig module IS : sig type t = Mapified_set(ASS64).t type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list end type db = { m : int; db : field array array; fields : string array; display_names : string array; package_field : int; version_field : int; index : int SSM.t; universe : IS.t; } and field = string type load_context = { field_index : (string, int) Hashtbl.t; non_canonical_names : (string, string) Hashtbl.t; mutable field_count : int; read_buffer : Buffer.t; mutable package_count : int; mutable packages : (int * string) list list; shared_strings : (string, string) Hashtbl.t; } val hashtable_overhead : int val create_load_context : unit -> load_context val binary_search : 'a array -> 'a -> int val field_of_string : db -> string -> int val string_of_field : db -> int -> string val display_name_of_field : db -> int -> string val display_string_of_field : db -> int -> string val name_of : db -> int -> field val version_of : db -> int -> field val key_of : db -> int -> field * field val find_package : db -> string -> string -> int val get_package : db -> int -> field array val get_field : db -> int -> int -> field val get_field_from_package : 'a -> 'b array -> int -> 'b val get_universe : db -> IS.t val get_fields : db -> string array val get_count : db -> int val get_display_names : db -> string array val package_field : db -> int val version_field : db -> int exception Malformed_line of string val decompose_line : string -> string * string val first_non_space : string -> int val read_tags : fast:bool -> load_context -> in_channel -> (int * string) list val load_single_file : fast:bool -> ?progress:(string -> int -> unit) -> load_context -> string -> unit val flip_array : 'a array -> unit val collect_field_values : db -> int -> SSet.elt list val find_database_files : (string * string) list -> string list val load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> db end ara-1.0.31/libara/debver.ml0000644000000000000000000000763411553072337012300 0ustar (* Debver *) (* $Id$ *) (* version ::= | epoch':'.upstream_version.'-'.debian_revision | upstream_version_no_colon.'-'.debian_revision | upstream_version_no_colon_no_dash | epoch':'.upstream_version_no_dash * epoch ::= [0-9]+ * upstream_version ::= [a-zA-Z0-9.+-:]+ * upstream_version_no_colon ::= [a-zA-Z0-9.+-]+ * upstream_version_no_dash ::= [a-zA-Z0-9.+:]+ * upstream_version_no_colon_no_dash ::= [a-zA-Z0-9.+]+ * debian_revision ::= [a-zA-Z0-9+.]+ *) let extract_epoch x = try let ci = String.index x ':' in if ci < String.length x - 1 then let epoch = String.sub x 0 ci and rest = String.sub x (ci + 1) (String.length x - ci - 1) in (epoch,rest) else ("",x) with | Not_found -> ("",x) ;; let extract_revision x = try let di = String.rindex x '-' in if di < String.length x - 1 then let upstream = String.sub x 0 di and revision = String.sub x (di + 1) (String.length x - di - 1) in (upstream,revision) else (x,"") with | Not_found -> (x,"") ;; let extract_chunks x = let (epoch,rest) = extract_epoch x in let (upstream,revision) = extract_revision rest in (epoch,upstream,revision) ;; let ( ** ) x y = if x = 0 then y else x;; let ( *** ) x y = if x = 0 then y () else x;; let ( ~~~ ) f x = not (f x) let order = function | `C '~' -> (0,'~') | `C('0'..'9' as c) -> (1,c) | `E -> (2,'\000') | `C('a'..'z'|'A'..'Z' as c) -> (3,c) | `C(c) -> (4,c) ;; let compare_couples (x1,x2) (y1,y2) = (compare x1 y1) ** (compare x2 y2);; let compare_special x y = let m = String.length x and n = String.length y in let rec loop i = let cx = if i >= m then `E else `C(x.[i]) and cy = if i >= n then `E else `C(y.[i]) in (compare_couples (order cx) (order cy)) *** (fun () -> if i > m or i > n then 0 else loop (i + 1)) in loop 0 ;; (* -1 : x < y *) let compare_numeric_decimal x y = let m = String.length x and n = String.length y in let rec loop1 i j = if i = m then if j < n then loop2 i j else 0 else if j = n then loop2 i j else if x.[i] = y.[j] then loop1 (i + 1) (j + 1) else loop2 i j and loop2 i j = if i = m then if j < n then -1 else 0 else if j = n then 1 else if m - i < n - j then -1 else if m - i > n - j then 1 else if x.[i] < y.[j] then -1 else if x.[i] > y.[j] then 1 else loop2 (i + 1) (j + 1) in loop1 0 0 ;; let rec compare_chunks x y = if x = y then 0 else let x1,x2 = Util.longest_matching_prefix (~~~ Util.is_digit) x and y1,y2 = Util.longest_matching_prefix (~~~ Util.is_digit) y in let c = compare_special x1 y1 in if c <> 0 then c else let (x21,x22) = Util.longest_matching_prefix Util.is_digit x2 and (y21,y22) = Util.longest_matching_prefix Util.is_digit y2 in let c = compare_numeric_decimal x21 y21 in if c <> 0 then c else compare_chunks x22 y22 ;; let compare_versions x1 x2 = let (e1,u1,r1) = extract_chunks x1 and (e2,u2,r2) = extract_chunks x2 in (compare_numeric_decimal e1 e2) *** (fun () -> (compare_chunks u1 u2) *** (fun () -> compare_chunks r1 r2)) ;; let test fn = let ic = open_in fn in try while true do let w = input_line ic in if w <> "" && w.[0] <> '#' then begin match Util.split_at ' ' w with | [x;y;z] -> let z' = int_of_string z in let r = compare_versions x y in if r = z' then Printf.printf "OK %S vs %S gives %d\n" x y r else Printf.printf "ERROR %S vs %S gives %d should give %d\n" x y r z' | _ -> () end; done; raise End_of_file with | End_of_file -> close_in ic ;; ara-1.0.31/libara/universe.ml0000644000000000000000000000215411553072337012661 0ustar (* Universe *) (* $Id: universe.ml,v 1.1 2004/07/20 14:17:04 berke Exp $ *) (* A universe is a set of documents. A result within a universe is a subset * of the universe. * Concretely, a document is a file, ie. a filename. * The Universe module provides : 1) integer <-> string bijection and 2) set operations. *) type 'a t = { table : (int,'a) Hashtbl.t; index : ('a,int) Hashtbl.t; mutable counter : int; } let create () = { table = Hashtbl.create 256; index = Hashtbl.create 256; counter = 0 } let clear u = Hashtbl.clear u.table; Hashtbl.clear u.index; u.counter <- 0 let register u x = try Hashtbl.find u.index x with | Not_found -> let id = u.counter in Hashtbl.add u.index x id; Hashtbl.add u.table id x; u.counter <- id + 1; id let lookup u i = Hashtbl.find u.table i module S = Set.Make(struct type t = int let compare i j = compare i j end) let iter u f = for i = 0 to u.counter - 1 do f i (Hashtbl.find u.table i) done let all u = let rec loop i s = if i = u.counter then s else loop (i + 1) (S.add i s) in loop 0 S.empty ara-1.0.31/libara/ara.mli0000644000000000000000000000240211553072336011730 0ustar (* Ara *) (* $Id: ara.mli,v 1.1 2004/10/26 09:44:54 berke Exp $ *) module Make : functor (Dpkg : Dpkg.DB) -> sig type statement = Ast.statement and query = Ast.set_query and result = Dpkg.IS.t val hierarchical : string -> string -> int val predicate : Ast.pattern -> string -> bool val eval_statement : get:(Ast.ident -> result) -> set:(Ast.ident -> result -> int -> int -> Ast.set_query -> 'a) -> ?cf:Ast.field_spec -> Dpkg.db -> Ast.statement -> result val sorted_list_of_query : Dpkg.db -> result -> int list val eval : get:(Ast.ident -> result) -> set:(Ast.ident -> result -> int -> int -> Ast.set_query -> 'a) -> cf:Ast.field_spec -> Dpkg.db -> Ast.set_query -> result val eval_atom : get:(Ast.ident -> result) -> set:(Ast.ident -> result -> int -> int -> Ast.set_query -> 'a) -> cf:Ast.field_spec -> Dpkg.db -> Ast.atomic_set -> result exception Parse_error of int * int * string val statement_of_string : string -> statement val compute_query : Dpkg.db -> get:(Ast.ident -> result) -> set:(Ast.ident -> result -> int -> int -> Ast.set_query -> 'a) -> Ast.statement -> int list val filter_old_versions : Dpkg.db -> int list -> int list end ara-1.0.31/libara/slurp.ml0000644000000000000000000000272311553072337012170 0ustar (* Slurp *) (* $Id: slurp.ml,v 1.1 2004/07/20 14:17:04 berke Exp $ *) open Unix type entry = | File of string * file_info | Directory of string * entry list | Error of string * exn and file_info = { file_size : int; } let with_chdir_to path f = let cwd = Sys.getcwd () in try Sys.chdir path; let r = f () in Sys.chdir cwd; r with | x -> Sys.chdir cwd; raise x let slurp path = with_chdir_to path (fun () -> let marked = Hashtbl.create 256 in let rec examine path = let d = opendir path in Sys.chdir path; let r = ref [] in try while true do let fn = readdir d in match fn with | "."|".." -> () | x -> try let st = lstat fn in match st.st_kind with | S_REG -> if not (Hashtbl.mem marked st.st_ino) then begin Hashtbl.add marked st.st_ino true; r := (File(fn,{ file_size = st.st_size }))::!r end | S_DIR -> r := (Directory(fn,examine (Filename.concat path fn)))::!r; Sys.chdir path | _ -> () with | y -> r := (Error(fn,y))::!r done; assert false with | End_of_file -> closedir d; !r | x -> closedir d; raise x in Directory(path,examine path)) ara-1.0.31/libara/debver.mli0000644000000000000000000000017711553072336012443 0ustar val compare_numeric_decimal : string -> string -> int val compare_versions : string -> string -> int val test : string -> unit ara-1.0.31/libara/lexic.mli0000644000000000000000000000060011553072336012267 0ustar exception Parse_error of int * int * string val lexical_error : Lexing.lexbuf -> string -> 'a val token : Lexing.lexbuf -> Syntax.token val eat_comment : Lexing.lexbuf -> unit val readstr : Lexing.lexbuf -> string val readregexp : Lexing.lexbuf -> string * Ast.regexp_option list val readregexpoptions : Lexing.lexbuf -> Ast.regexp_option list val readident : Lexing.lexbuf -> string ara-1.0.31/libara/ast.ml0000644000000000000000000000731111553072337011610 0ustar (* AST *) (* $Id: ast.ml,v 1.3 2004/07/25 20:40:23 berke Exp $ *) type ident = string type ('a,'b) boolean = | And of ('a,'b) boolean * ('a,'b) boolean | Or of ('a,'b) boolean * ('a,'b) boolean | Not of ('a,'b) boolean | True | False | Atom of 'a | Meta of 'b * ('a,'b) boolean and 'a relational = | Identity | Union of 'a relational * 'a relational | Intersection of 'a relational * 'a relational | Complement of 'a relational | Star of 'a relational | Plus of 'a relational | Compose of 'a relational * 'a relational | Reverse of 'a relational | Relation of 'a type regexp_option = | Case_insensitive | Word_boundary type statement = | Assign of ident * int * int * set_query | Display of set_query and relation = | Field_link of field_spec and atomic_set = | Matches of field_spec * pattern | Reference of ident and pattern = | Exact of string | Lexicographic_le of string | Lexicographic_lt of string | Lexicographic_ge of string | Lexicographic_gt of string | Regular of string * regexp_option list and field_spec = | Current_field | Some_field of pattern | This_field of string | Either_field of field_spec * field_spec and meta = | With_field of field_spec | Apply_relation of relation relational and set_query = (atomic_set, meta) boolean let string_of_regexp_option = function | Case_insensitive -> "Case_insensitive" | Word_boundary -> "Word_boundary" let rec dump_set_query f = function | Matches(fd,pat) -> Format.fprintf f "Matches(@["; dump_field f fd; Format.fprintf f ",@,"; dump_pattern f pat; Format.fprintf f "@])" | Reference(id) -> Format.fprintf f "Reference(%s)" id and dump_set_query_boolean f = function | And(qb1,qb2) -> Format.fprintf f "And(@["; dump_set_query_boolean f qb1; Format.fprintf f ",@,"; dump_set_query_boolean f qb2; Format.fprintf f "@])" | Or(qb1,qb2) -> Format.fprintf f "Or(@["; dump_set_query_boolean f qb1; Format.fprintf f ",@,"; dump_set_query_boolean f qb2; Format.fprintf f "@])" | Not(qb) -> Format.fprintf f "Not(@["; dump_set_query_boolean f qb; Format.fprintf f "@])" | Atom(q) -> Format.fprintf f "Atom(@["; dump_set_query f q; Format.fprintf f "@])" | True -> Format.fprintf f "True" | False -> Format.fprintf f "False" | Meta(With_field(fs),qb) -> Format.fprintf f "With_field(@["; dump_field f fs; Format.fprintf f ",@,"; dump_set_query_boolean f qb; Format.fprintf f "@])" | Meta(Apply_relation(r),qb) -> Format.fprintf f "Meta(Apply_relation(@[..., "; dump_set_query_boolean f qb; Format.fprintf f "@])" and dump_statement f = function | Display(qb) -> Format.fprintf f "Display(@["; dump_set_query_boolean f qb; Format.fprintf f "@])" | Assign(id,i1,i2,qb) -> Format.fprintf f "Assign(@[%s, %d, %d, " id i1 i2; dump_set_query_boolean f qb; Format.fprintf f "@])" and dump_field f = function | Either_field(f1,f2) -> Format.fprintf f "Either_field(@["; dump_field f f1; Format.fprintf f ",@,"; dump_field f f2; Format.fprintf f "@])" | Some_field(pat) -> Format.fprintf f "Some_field(@["; dump_pattern f pat; Format.fprintf f "@])" | This_field(x) -> Format.fprintf f "This_field(%S)" x | Current_field -> Format.fprintf f "Current_field" and dump_pattern f = function | Exact(x) -> Format.fprintf f "Exact(%S)" x | Lexicographic_le(x) -> Format.fprintf f "Lexicographic_le(%S)" x | Lexicographic_lt(x) -> Format.fprintf f "Lexicographic_lt(%S)" x | Lexicographic_ge(x) -> Format.fprintf f "Lexicographic_ge(%S)" x | Lexicographic_gt(x) -> Format.fprintf f "Lexicographic_gt(%S)" x | Regular(x,y) -> Format.fprintf f "Regular(%S,[%s])" x (String.concat ";" (List.map string_of_regexp_option y)) let dump f s = dump_statement f s; Format.fprintf f "@." ara-1.0.31/libara/dpkg.ml0000644000000000000000000007346411553072337011762 0ustar (* Dpkg *) (* $Id: dpkg.ml,v 1.9 2004/10/26 09:44:54 berke Exp $ *) (*** SS, SSM, IM *) module SS = struct type t = string * string let compare = compare end ;; module SSM = Map.Make(SS);; module IM = Map.Make(struct type t = int let compare = compare end);; (* ***) (*** BIG_SET *) module type BIG_SET = sig type t type u type v type elt = int val fold : (int -> 'b -> 'b) -> t -> 'b -> 'b val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list val create_compression_buffer : unit -> v val compress : v -> t -> u val decompress : v -> u -> t end ;; (* ***) (*** IS *) module IS = struct type t = string type u = Rle.t type v = Buffer.t type elt = int let empty = "" let range m = let n = (m + 7) lsr 3 in let u = String.make n '\255' in u.[n - 1] <- Char.chr (255 lsr (7 land (8 - (m land 7)))); u ;; let copy u = String.copy u;; let set i u = let m = String.length u in let i' = i lsr 3 in let v = if i' >= m then let v = String.make (i' + 1) '\000' in String.blit u 0 v 0 m; v else u in v.[i'] <- Char.chr (Char.code v.[i'] lor (1 lsl (i land 7))); v ;; let add i u = let m = String.length u in let i' = i lsr 3 in let v = if i' >= m then let v = String.make (i' + 1) '\000' in String.blit u 0 v 0 m; v else String.copy u in v.[i'] <- Char.chr (Char.code v.[i'] lor (1 lsl (i land 7))); v ;; let weight_table = let a = Array.make 256 0 in for i = 1 to 255 do a.(i) <- a.(i lsr 1) + (if i land 1 <> 0 then 1 else 0) done; a ;; let fold f u q0 = let rec loop1 i y j q = if j = 8 then q else loop1 (i + 1) (y lsr 1) (j + 1) (if 0 <> y land 1 then f i q else q) in let m = String.length u in let rec loop2 i q = if i = m then q else loop2 (i + 1) (loop1 (i lsl 3) (Char.code u.[i]) 0 q) in loop2 0 q0 ;; let elements y = fold (fun i l -> i::l) y [];; let cardinal u = let m = String.length u in let rec loop c i = if i = m then c else loop (c + weight_table.(Char.code u.[i])) (i + 1) in loop 0 0 ;; let is_empty u = let m = String.length u in let rec loop i = i = m or u.[i] = '\000' && loop (i + 1) in loop 0 ;; let rec diff u v = let m = String.length u and n = String.length v in let w = String.create m in for i = 0 to (min m n) - 1 do w.[i] <- Char.chr ((Char.code u.[i]) land (lnot (Char.code v.[i]))) done; for i = min m n to m - 1 do w.[i] <- u.[i] done; w ;; let rec inter u v = let m = String.length u and n = String.length v in if m > n then inter v u else let w = String.create m in for i = 0 to m - 1 do w.[i] <- Char.chr ((Char.code u.[i]) land (Char.code v.[i])) done; w ;; let rec union u v = let m = String.length u and n = String.length v in if m > n then union v u else let w = String.create n in for i = 0 to m - 1 do w.[i] <- Char.chr ((Char.code u.[i]) lor (Char.code v.[i])) done; for i = m to n - 1 do w.[i] <- v.[i] done; w ;; let create_compression_buffer () = Buffer.create 16;; let compress b u = Rle.compress b u;; let decompress b u = Rle.decompress b u;; (*let mem i u = let m = String.length u in let i' = i lsr 3 in i < m && 0 <> Char.code u.[i] land (1 lsl (i land 3)) ;;*) end ;; (* ***) module SM = Map.Make(String);; module SSet = Set.Make(String);; (* ***) (*** decompose_line *) let decompose_line l = let i = String.index l ':' in (String.sub l 0 i, Util.remove_leading_spaces (String.sub l (i + 1) (String.length l - i - 1))) ;; (* ***) (*** first_non_space *) let first_non_space = Util.first_matching_char (fun c -> not (Util.is_space c));; (* ***) (*** paragraph_folder *) class paragraph_folder : object method output : out_channel -> unit method get : string method add_line : string -> unit method add_string : string -> unit method reset : unit end = object(self) val b = Buffer.create 16 val mutable mode = `Header method get = Buffer.contents b method output oc = Buffer.output_buffer oc b method reset = mode <- `Header; Buffer.clear b method add_string u = let l = Util.split_at '\n' u in List.iter self#add_line l method add_line l = let m = String.length l in if m = 0 then () else match l.[0] with | (' '|'\t') -> if l = " ." then begin match mode with | `Parskip|`Star|`Star_header|`Body -> mode <- `Parskip | `Header -> mode <- `Body end else begin try let i = first_non_space l in if l.[i] = '*' or l.[i] = '-' then begin match mode with | `Star|`Star_header|`Parskip -> Buffer.add_string b "\n"; Buffer.add_substring b l i (m - i); mode <- `Star | `Body|`Header -> Buffer.add_string b "\n\n"; Buffer.add_substring b l i (m - i); mode <- `Star_header end else if i > 1 then begin match mode with | `Star|`Star_header -> Buffer.add_char b ' '; Buffer.add_substring b l i (m - i); mode <- `Star | `Header|`Parskip|`Body -> Buffer.add_string b "\n\n"; Buffer.add_substring b l i (m - i); mode <- `Body end else begin match mode with | `Star|`Star_header -> Buffer.add_char b ' '; Buffer.add_substring b l i (m - i); mode <- `Star | `Body -> Buffer.add_char b ' '; Buffer.add_substring b l i (m - i); mode <- `Body | `Header|`Parskip -> Buffer.add_string b "\n\n"; Buffer.add_substring b l i (m - i); mode <- `Body end with | Not_found -> mode <- `Parskip end | _ -> Buffer.add_string b l end ;; (* ***) (*** dbg *) type ('methods,'extra,'field) dbg = { m : int; (* number of packages *) db : 'field array array; (* packages *) fields : string array; (* field id -> field name *) display_names : string array; (* fidl id -> display field name *) package_field : int; version_field : int; index : int SSM.t; (* key -> int *) universe : IS.t; (* all packages *) extra : 'extra; methods : 'methods } (* ***) (*** load_context *) type ('extra, 'field) load_context = { field_index : (string,int) Hashtbl.t; non_canonical_names : (string,string) Hashtbl.t; mutable field_count : int; read_buffer : Buffer.t; mutable package_count : int; mutable packages : (int * 'field) list list; mutable ctx_extra : 'extra (* shared_strings : (string,string) Hashtbl.t *) };; (* ***) (*** line_reader *) class line_reader ic = let m = 8192 in object(self) val u = String.make m '\000' val mutable i = 0 (* bytes 0..i-1 have already been processed *) val mutable j = 0 (* length of buffer *) val mutable offset = 0 (* offset of byte zero of buffer *) val b = Buffer.create m method get_offset = offset (* ok *) method reset = offset <- 0; i <- 0; j <- 0 (* *) method refill = assert (i >= j); (* refuse to refill if all bytes have not been consumed *) let j' = j in (* save old buffer length *) j <- input ic u 0 m; (* input some bytes *) i <- 0; (* reset pointer *) offset <- offset + j' (* update offset *) method input_line_with_offset = let o = offset + i in (* offset of beginning of line *) Buffer.clear b; let rec find i = (* find first '\n', return j otherwise *) if i = j then j else if u.[i] = '\n' then i else find (i + 1) in (* read a complete line *) let rec loop () = if i >= j then self#refill; let k = if j = 0 then if Buffer.length b > 0 then j else raise End_of_file else find i in Buffer.add_substring b u i (k - i); i <- k + 1; if k < j then (* we have a new line *) begin let v = Buffer.contents b in let r = Some(v, o, o + String.length v) in r end else (* not yet finished *) loop () in try loop () with | End_of_file -> None end (* ***) (*** DBT *) module type DBT = sig type extra type field class database_loader : object ('a) method create_load_context : (extra, field) load_context method display_name_of_field : ('a, extra, field) dbg -> int -> string method display_string_of_field : ('a, extra, field) dbg -> int -> string method empty_field : field method field_of_string : ('a, extra, field) dbg -> string -> int method find_package : ('a, extra, field) dbg -> string -> string -> int method get_count : ('a, extra, field) dbg -> int method get_display_names : ('a, extra, field) dbg -> string array method get_field : ('a, extra, field) dbg -> int -> int -> string method get_field_from_package : ('a, extra, field) dbg -> field array -> int -> string method get_fields : ('a, extra, field) dbg -> string array method get_package : ('a, extra, field) dbg -> int -> string array method get_universe : ('a, extra, field) dbg -> IS.t method is_field_empty : field -> bool method key : (extra, field) load_context -> field -> field -> string * string method key_of : ('a, extra, field) dbg -> int -> string * string method name_of : ('a, extra, field) dbg -> int -> string method package_field : ('a, extra, field) dbg -> int method string_of_field : ('a, extra, field) dbg -> int -> string method version_field : ('a, extra, field) dbg -> int method version_of : ('a, extra, field) dbg -> int -> string method load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> ('a, extra, field) dbg method load_single_file : fast:bool -> ?progress:(string -> int -> unit) -> (extra, field) load_context -> string -> unit (*method make_field : context:(extra, field) load_context -> fast:bool -> file_id:int -> start_offset:int -> end_offset:int -> field_name:string -> field_contents:string -> first_line:string -> field*) (*method read_tags : ?fast:bool -> int -> (extra, field) load_context -> reader:line_reader -> (int * field) list*) end end ;; (* ***) (*** Misc *) class pf = paragraph_folder;; module Misc(DBT : DBT) = struct open DBT type db = (database_loader, extra, field) dbg class paragraph_folder = pf module IS = IS let field_of_string (db : db) = db.methods#field_of_string db;; let string_of_field (db : db) = db.methods#string_of_field db;; let display_name_of_field (db : db) = db.methods#display_name_of_field db;; let display_string_of_field (db : db) = db.methods#display_string_of_field db;; let name_of (db : db) = db.methods#name_of db;; let version_of (db : db) = db.methods#version_of db;; let key_of (db : db) = db.methods#key_of db;; let find_package (db : db) = db.methods#find_package db;; let get_package (db : db) = db.methods#get_package db;; let get_field (db : db) = db.methods#get_field db;; let get_field_from_package (db : db) = db.methods#get_field_from_package db;; let get_universe (db : db) = db.methods#get_universe db;; let get_fields (db : db) = db.methods#get_fields db;; let get_count (db : db) = db.methods#get_count db;; let get_display_names (db : db) = db.methods#get_display_names db;; let package_field (db : db) = db.methods#package_field db;; let version_field (db : db) = db.methods#version_field db;; end ;; (* ***) (*** DB *) module type DB = sig module IS : BIG_SET type db and field val field_of_string : db -> string -> int val string_of_field : db -> int -> string val display_name_of_field : db -> int -> string val display_string_of_field : db -> int -> string val name_of : db -> int -> string val version_of : db -> int -> string val key_of : db -> int -> string * string val find_package : db -> string -> string -> int val get_package : db -> int -> string array val get_field : db -> int -> int -> string exception Malformed_line of string val find_database_files : (string * string) list -> string list val load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> db val get_universe : db -> IS.t val get_fields : db -> string array val get_count : db -> int val get_display_names : db -> string array val package_field : db -> int val version_field : db -> int val backend : string class paragraph_folder : object method output : out_channel -> unit method get : string method add_line : string -> unit method add_string : string -> unit method reset : unit end end ;; (* ***) (*** create_load_context *) let create_load_context extra = { field_index = Hashtbl.create 16; non_canonical_names = Hashtbl.create 16; field_count = 0; read_buffer = Buffer.create 16; package_count = 0; packages = []; ctx_extra = extra };; (* ***) (*** binary_search *) let binary_search a x = let m = Array.length a in let rec loop i0 m = if m = 0 then raise Not_found else begin if m < 8 then if a.(i0) = x then i0 else loop (i0 + 1) (m - 1) else let i = i0 + m / 2 in let y = a.(i) in if x = y then i else if x < y then loop i0 (m / 2) else loop (i + 1) (m - m / 2) end in loop 0 m ;; (* ***) exception Malformed_line of string;; (*** collect_field_values *) let collect_field_values db j = let a = db.db in let rec loop i r = if i = Array.length a then r else loop (i + 1) (if a.(i).(j) <> "" then SSet.add a.(i).(j) r else r) (* XXX *) in let s = loop 0 SSet.empty in SSet.elements s ;; (* ***) (*** find_database_files *) let find_database_files dbfn = List.fold_left (fun l (path,patt) -> let fns = Slurp.slurp path in let re = Str.regexp patt in let rec loop curpath (l : string list) = function | Slurp.File(fn,_) -> if try ignore (Str.search_forward re fn 0); true with Not_found -> false then (Filename.concat curpath fn)::l else l | Slurp.Directory(d,fl) -> List.fold_left (fun l t -> loop (Filename.concat curpath d) l t) l fl | Slurp.Error(_,_) -> l in loop "" l fns) [] dbfn ;; (* ***) (*** database *) class virtual ['extra,'field,'file_id] database = object(self : 'a) method field_of_string (db : ('a,'extra,'field) dbg) w = binary_search db.fields w method string_of_field (db : ('a,'extra,'field) dbg) f = db.fields.(f) method display_name_of_field (db : ('a,'extra,'field) dbg) (f : int) : string = db.display_names.(f) method display_string_of_field (db : ('a,'extra,'field) dbg) f = db.display_names.(f) method virtual name_of : ('a,'extra,'field) dbg -> int -> string method virtual version_of : ('a,'extra,'field) dbg -> int -> string method key_of db i = (self#name_of db i, self#version_of db i) (*method virtual key_of : ('a,'extra,'field) dbg -> int -> string * string*) method find_package (db : ('a,'extra,'field) dbg) pn pv = SSM.find (pn, pv) db.index method virtual get_package : ('a,'extra,'field) dbg -> int -> string array method virtual get_field : ('a,'extra,'field) dbg -> int -> int -> string method virtual get_field_from_package : ('a,'extra,'field) dbg -> 'field array -> int -> string method get_universe (db : ('a,'extra,'field) dbg) = db.universe method get_fields (db : ('a,'extra,'field) dbg) = db.fields method get_count (db : ('a,'extra,'field) dbg) = db.m method get_display_names (db : ('a,'extra,'field) dbg) = db.display_names method package_field (db : ('a,'extra,'field) dbg) = db.package_field method version_field (db : ('a,'extra,'field) dbg) = db.version_field method private virtual make_field : context:('extra,'field) load_context -> fast:bool -> file_id:'file_id -> start_offset:int -> end_offset:int -> field_name:string -> field_contents:string -> first_line:string -> 'field (* (*** input_line_with_offset *) method input_line_with_offset b offset ic = Buffer.clear b; let o1 = !offset in let rec loop () = match try Some(input_char ic) with End_of_file -> None with | Some('\n'|'\000')|None -> let o2 = !offset in incr offset; Some(Buffer.contents b,o1,o2-1) | Some(c) -> incr offset; Buffer.add_char b c; loop () in loop () (* ***) *) (*** read_tags *) method private read_tags ?(fast=false) file_id ctx ~(reader : line_reader) = let b = ctx.read_buffer in Buffer.clear b; let add_row ~(rows : (int * 'field) list) ~end_offset = function | None -> rows | Some(field_name, start_offset, first_line) -> (* Find the corresponding field id *) let x' = String.lowercase field_name in let i = try let x'' = Hashtbl.find ctx.non_canonical_names x' in if field_name < x'' then Hashtbl.replace ctx.non_canonical_names x' field_name; Hashtbl.find ctx.field_index x' with | Not_found -> let i = ctx.field_count in Hashtbl.add ctx.field_index x' i; Hashtbl.add ctx.non_canonical_names x' field_name; ctx.field_count <- i + 1; i in let y = Buffer.contents b in Buffer.clear b; let y = self#make_field ~context:ctx ~fast ~file_id ~start_offset ~end_offset ~field_name:x' ~field_contents:y ~first_line in ((i,y)::rows) in (* Header -- Body -- Parskip -- Star *) let rec loop ~rows ~pending = match reader#input_line_with_offset with | None -> add_row ~rows ~end_offset:(reader#get_offset) pending (* ... *) | Some(l,o1,o2) -> let m = String.length l in if m = 0 then add_row ~rows ~end_offset:o2 pending (* ... *) else match l.[0] with | (' '|'\t') -> Buffer.add_char b '\n'; Buffer.add_string b l; loop ~rows ~pending | _ -> let rows = add_row ~rows ~end_offset:o1 pending in let (x,y) = try decompose_line l with | Not_found -> raise (Malformed_line(l)) in Buffer.add_string b y; loop ~rows ~pending:(Some(x,o1 + m - String.length y,y)) in loop ~rows:[] ~pending:None (* ***) (*** load_single_file *) method virtual load_single_file : fast:bool -> ?progress:(string -> int -> unit) -> ('extra, 'field) load_context -> string -> unit (* ***) method virtual empty_field : 'field method virtual is_field_empty : 'field -> bool method virtual create_load_context : ('extra,'field) load_context method load ?(fast=false) ?(progress = fun _ _ -> ()) fnl = let ctx = self#create_load_context in List.iter (fun fn -> self#load_single_file ~fast ~progress ctx fn) fnl; (* let's sort fields *) let fields = Array.make ctx.field_count (0,"") in Hashtbl.iter (fun w i -> fields.(i) <- (i,w)) ctx.field_index; Array.sort (fun (_,w1) (_,w2) -> compare w1 w2) fields; let translate = Array.make ctx.field_count 0 in for i = 0 to ctx.field_count - 1 do let (j,_) = fields.(i) in translate.(j) <- i done; let fields = Array.map (fun (_,w) -> w) fields in let package_field = translate.(Hashtbl.find ctx.field_index "package") and version_field = translate.(Hashtbl.find ctx.field_index "version") in let array_of_row row = let a = Array.make ctx.field_count self#empty_field in (*List.iter (fun (i,w) -> if a.(translate.(i)) = "" then a.(translate.(i)) <- w) row;*) List.iter (fun (i,w) -> if self#is_field_empty a.(translate.(i)) then a.(translate.(i)) <- w) row; a in let key a = self#key ctx a.(package_field) a.(version_field) in let b = Array.of_list ctx.packages in let db = Array.make (Array.length b) [||] in let rec build i index j = if j = Array.length b then i,index,db else let row = b.(j) in let a = array_of_row row in let ((p,v) as k) = key a in if SSM.mem k index then begin let i' = SSM.find k index in let a' = db.(i') in for l = 0 to Array.length a - 1 do if self#is_field_empty a'.(l) && not (self#is_field_empty a.(l)) then begin a'.(l) <- a.(l) end else () done; build i index (j + 1) end else begin db.(i) <- a; build (i + 1) (SSM.add k i index) (j + 1) end in let m,index,db = build 0 SSM.empty 0 in let db = Array.sub db 0 m in let universe = IS.range m in { m = m; db = db; fields = fields; display_names = Array.map (fun f -> Hashtbl.find ctx.non_canonical_names f) fields; package_field = package_field; version_field = version_field; index = index; universe = universe; extra = ctx.ctx_extra; methods = self } end ;; (* ***) module V = Virtual_strings;; (*** DBFS *) module DBFS : DB = struct (*** database_loader *) class database_loader = let empty_field = V.make_real_string "" in let reify db x = V.get_string db.extra x in object(self : 'a) inherit [V.pool, V.t, int] database as super method get_package db i = Array.map (reify db) db.db.(i) method get_field db i j = reify db db.db.(i).(j) method get_field_from_package db p j = reify db p.(j) method name_of db i = reify db db.db.(i).(db.package_field) method version_of db i = reify db db.db.(i).(db.version_field) method empty_field = V.empty_string method is_field_empty x = V.is_empty x method key ctx package version = (V.get_real_string ctx.ctx_extra package, V.get_real_string ctx.ctx_extra version) method private make_field ~context ~fast ~file_id ~start_offset ~end_offset ~field_name ~field_contents ~first_line = (*Printf.eprintf "make_field file %d start %d end %d name %S contents %S\n" file_id start_offset end_offset field_name field_contents; *) if field_name = "package" or field_name = "version" then V.make_real_string first_line else V.make_virtual_string context.ctx_extra file_id start_offset (end_offset - start_offset - 1) (* XXX *) method create_load_context = create_load_context (V.create ()) method load_single_file ~fast ?(progress = fun _ _ -> ()) ctx fn = let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in let ic = Unix.in_channel_of_descr fd in let reader = new line_reader ic in let fi = V.add_file ctx.ctx_extra fn fd in let rec loop i = if i land 1023 = 0 then begin progress fn ctx.package_count; end; let l = self#read_tags fi ctx ~reader in if l = [] then (* close_in ic *) () else begin ctx.packages <- l::ctx.packages; ctx.package_count <- 1 + ctx.package_count; loop (i + 1) end in loop 0 end let find_database_files = find_database_files exception Malformed_line of string (* XXX *) let loader = new database_loader let load = loader#load (* ***) type dbi = (database_loader, V.pool, V.t) dbg type field = V.t class dl = database_loader module M = Misc(struct type field = V.t and extra = V.pool class database_loader = dl end) include M open M let backend = "DBFS";; (*let field_of_string (db : db) = db.methods#field_of_string db;; let string_of_field (db : db) = db.methods#string_of_field db;; let display_name_of_field (db : db) = db.methods#display_name_of_field db;; let display_string_of_field (db : db) = db.methods#display_string_of_field db;; let name_of (db : db) = db.methods#name_of db;; let version_of (db : db) = db.methods#version_of db;; let key_of (db : db) = db.methods#key_of db;; let find_package (db : db) = db.methods#find_package db;; let get_package (db : db) = db.methods#get_package db;; let get_field (db : db) = db.methods#get_field db;; let get_field_from_package (db : db) = db.methods#get_field_from_package db;; let get_universe (db : db) = db.methods#get_universe db;; let get_fields (db : db) = db.methods#get_fields db;; let get_count (db : db) = db.methods#get_count db;; let get_display_names (db : db) = db.methods#get_display_names db;; let package_field (db : db) = db.methods#package_field db;; let version_field (db : db) = db.methods#version_field db;;*) end ;; (* ***) (*** DBRAM *) module DBRAM : DB = struct (*** database_loader *) class database_loader = let empty_field = V.make_real_string "" in let reify db x = V.get_string db.extra x in object(self : 'a) inherit [(string,string) Hashtbl.t, string, string] database as super method get_package db i = db.db.(i) method get_field db i j = db.db.(i).(j) method get_field_from_package db p j = p.(j) method name_of db i = db.db.(i).(db.package_field) method version_of db i = db.db.(i).(db.version_field) method empty_field = "" method is_field_empty x = "" = x method key ctx package version = (package, version) method private make_field ~context ~fast ~file_id ~start_offset ~end_offset ~field_name ~field_contents ~first_line = let x = if field_name = "package" or field_name = "version" then first_line else field_contents in if fast then x else try Hashtbl.find context.ctx_extra x with | Not_found -> Hashtbl.add context.ctx_extra x x; x method create_load_context = create_load_context (Hashtbl.create 1024) method load_single_file ~fast ?(progress = fun _ _ -> ()) ctx fn = let ic = open_in fn in let reader = new line_reader ic in let rec loop i = if i land 1023 = 0 then begin progress fn ctx.package_count; end; let l = self#read_tags fn ctx ~reader in if l = [] then close_in ic else begin ctx.packages <- l::ctx.packages; ctx.package_count <- 1 + ctx.package_count; loop (i + 1) end in loop 0 end let find_database_files = find_database_files exception Malformed_line of string (* XXX *) let loader = new database_loader let load = loader#load (* ***) type dbi = (database_loader, (string, string) Hashtbl.t, string) dbg type field = V.t class dl = database_loader module M = Misc(struct type field = string and extra = (string, string) Hashtbl.t class database_loader = dl end) include M open M let backend = "DBRAM";; end ;; (* ***) ara-1.0.31/libara/ara.ml0000644000000000000000000001137511553072337011571 0ustar (* Ara *) (* $Id: ara.ml,v 1.2 2004/10/26 09:44:54 berke Exp $ *) module Make(Dpkg:Dpkg.DB) = struct open Ast open Dpkg open Util type statement = Ast.statement and query = set_query and result = Dpkg.IS.t (*** Predicate construction *) let hierarchical = Util.hierarchical;; let predicate = function | Exact(x) -> ((=) x) | Lexicographic_le(x) -> fun y -> Debver.compare_versions y x <= 0 | Lexicographic_lt(x) -> fun y -> Debver.compare_versions y x < 0 | Lexicographic_ge(x) -> fun y -> Debver.compare_versions y x >= 0 (* hierarchical *) | Lexicographic_gt(x) -> fun y -> Debver.compare_versions y x > 0 (* hierarchical *) | Regular(x,o) -> let reg = let x' = if List.mem Word_boundary o then "\\b"^x^"\\b" else x in if List.mem Case_insensitive o then Str.regexp_case_fold x' else Str.regexp x' in fun y -> try ignore (Str.search_forward reg y 0); true with Not_found -> false ;; exception Yes;; (* let dependencies st = let rec loop l = function | And(qb1,qb2)|Or(qb1,qb2) -> let l = loop l qb1 in loop l qb2 | Not(qb) -> loop l qb | True|False -> l | Meta(_,qb) -> loop l qb | Atom(Reference(id)) -> if List.mem id l then l else id::l | Atom(_) -> l in match st with | Statement(st) -> loop [] qb *) let default_field = Some_field(Regular("^\\(description\\|package\\)$",[]));; let rec eval_statement ~get ~set ?(cf=default_field) db = function | Display(q) -> eval ~get ~set ~cf db q | Assign(id,s1,s2,qb) -> let r = eval ~get ~set ~cf db qb in set id r s1 s2 qb; r and eval ~get ~set ~cf db = function | And(qb1,qb2) -> IS.inter (eval ~get ~set ~cf db qb1) (eval ~get ~set ~cf db qb2) | Or(qb1,qb2) -> IS.union (eval ~get ~set ~cf db qb1) (eval ~get ~set ~cf db qb2) | Not(qb) -> IS.diff (get_universe db) (eval ~get ~set ~cf db qb) | True -> get_universe db | False -> IS.empty | Atom(x) -> eval_atom ~get ~set ~cf db x | Meta(With_field(cf),qb) -> eval ~get ~set ~cf db qb | _ -> assert false and eval_atom ~get ~set ~cf db = function | Reference(id) -> get id | Matches(Current_field,pat) -> eval_atom ~get ~set ~cf db (Matches(cf,pat)) | Matches(Some_field(fdpat),pat) -> let fdp = predicate fdpat and p = predicate pat in let fields = get_fields db in let m = get_count db in let rec loop acc i = if i = Array.length fields then acc else loop (if fdp fields.(i) then (i::acc) else acc) (i + 1) in let fds = loop [] 0 in (* List.iter (fun fd -> debug 0 (sf "selected field %d named %s" fd db.fields.(fd))) fds; *) let rec loop i x = if i = m then x else if List.exists (fun fd -> p (get_field db i fd)) fds then loop (i + 1) (IS.add i x) else loop (i + 1) x in loop 0 IS.empty | Matches(Either_field(f1,f2),pat) -> IS.union (eval_atom ~get ~set ~cf db (Matches(f1,pat))) (eval_atom ~get ~set ~cf db (Matches(f2,pat))) | Matches(This_field(fd),pat) -> let fdi = field_of_string db fd in let p = predicate pat in let m = get_count db in let rec loop i x = if i = m then x else if try p (get_field db i fdi) with | Not_found -> false then loop (i + 1) (IS.add i x) else loop (i + 1) x in loop 0 IS.empty ;; (* Predicate construction and evaluation ***) exception Parse_error of int * int * string;; let statement_of_string w : statement = let l = Lexing.from_string w in try Syntax.statement Lexic.token l with | Parsing.Parse_error -> raise (Parse_error(Lexing.lexeme_start l,Lexing.lexeme_end l,"Parse error")) | Failure x -> raise (Parse_error(Lexing.lexeme_start l,Lexing.lexeme_end l,"Failure: "^x)) | Lexic.Parse_error(i,j,x) -> raise (Parse_error(i,j,x)) ;; let sorted_list_of_query db x = List.sort (fun i j -> compare (name_of db i) (name_of db j)) (IS.elements x) ;; let compute_raw_query db ~get ~set q = let x = eval_statement db ~get ~set q in let xl = List.sort (fun i j -> compare (name_of db i) (name_of db j)) (IS.elements x) in xl ;; let compute_query db ~get ~set q = sorted_list_of_query db (eval_statement db ~get ~set q);; let filter_old_versions db x = let h = Hashtbl.create 256 in List.iter (fun i -> try let p = name_of db i and v = version_of db i in try let (v',i') = Hashtbl.find h p in if Debver.compare_versions v' v < 0 then Hashtbl.replace h p (v, i) else () with | Not_found -> Hashtbl.add h p (version_of db i, i) with | Not_found -> ()) x; let x' = ref [] in Hashtbl.iter (fun _ (_,i) -> x' := i::!x') h; !x' ;; (* let db : Dpkg.db option ref = ref None;; *) end ara-1.0.31/libara/rle.mli0000644000000000000000000000026411553072337011754 0ustar (* RLE *) type t exception Invalid_compressed_data of string val decompress : Buffer.t -> t -> string val emit_int : Buffer.t -> int -> unit val compress : Buffer.t -> string -> t ara-1.0.31/libara/virtual_strings.mli0000644000000000000000000000153011553072336014425 0ustar type file = { name : string; fd : Unix.file_descr; mtime : float; mutable mtime_counter : int; range_low : int; range_high : int; } and pool = { mutable count : int; mutable files : file array; mutable high : int; } and virtual_string = { beginning : int; length : int; } and t = Real of string | Virtual of virtual_string exception Error of string exception Not_real exception File_out_of_date of string val sf : ('a, unit, string) format -> 'a val create : unit -> pool val add_file : pool -> string -> Unix.file_descr -> int val find_file : pool -> int -> int val make_virtual_string : pool -> int -> int -> int -> t val empty_string : t val is_empty : t -> bool val make_real_string : string -> t val get_real_string : 'a -> t -> string val check_mtime_every : int ref val mtime_counter : int ref val get_string : pool -> t -> string ara-1.0.31/libara/lexic.mll0000644000000000000000000000462611553072337012307 0ustar { (* Lexic *) (* $Id: lexic.mll,v 1.5 2004/08/02 17:13:39 berke Exp $ *) open Syntax exception Parse_error of int * int * string let lexical_error l s = raise (Parse_error(Lexing.lexeme_start l, Lexing.lexeme_end l,s)) } let blancs = [' ' '\n' '\t' '\r']+ let upperalpha = ['A'-'Z'] let alpha = ['a'-'z''A'-'Z'] let alphanum = alpha | ['0'-'9'] let decimaldigit = ['0'-'9'] let sign = '+'|'-' let space = [' ''\t''\r''\n'] rule token = parse (* Operators *) (* Various non-alphabetic symbols *) | "(" { LPAREN } | ")" { RPAREN } | "[" { LBRACK } | "]" { RBRACK } | "," { COMMA } | "+" { PLUS } | "*" { STAR } | "~" { TILDE } | ":" { COLON } | "<>" { NEQ } | "!=" { NEQ } | "=" { EQ } | "<=" { LEQ } | ">=" { GEQ } | "<" { LT } | ">" { GT } | "," { COMMA } | "=~" { MATCHES } | "!~" { DOESNT_MATCH } | ":=" { ASSIGN } | "&" { AND } | "|" { OR } | "!" { NOT } | "^R" { REVERSE } | "and" { AND } | "or" { OR } | "not" { NOT } | "all" { TRUE } | "none" { FALSE } | "true" { TRUE } | "false" { FALSE } | "id" { IDENTITY } | "\"" { STRING(readstr lexbuf) } | "/" { REGEXP(readregexp lexbuf) } | "$"(alphanum|'_'|'-')+ { IDENT(let w = Lexing.lexeme lexbuf in String.sub w 1 (String.length w - 1)) } | (alphanum|'_'|'-'|'*'|'?')+ { STRING(Lexing.lexeme lexbuf) } (* Comments, space, strings and end of file *) | "(*" { eat_comment lexbuf; token lexbuf } | space+ { token lexbuf } | eof { EOF } | _ { lexical_error lexbuf (Printf.sprintf "Unexpected %S" (Lexing.lexeme lexbuf)) } and eat_comment = parse "(*" { eat_comment lexbuf; eat_comment lexbuf } | "*)" { } | [^'(' '*']+ { eat_comment lexbuf } | _ { eat_comment lexbuf } and readstr = parse "\"" { "" } | "\\\"" { "\""^(readstr lexbuf) } | [^'"' '\\']+ { let s = Lexing.lexeme lexbuf in s^(readstr lexbuf) } and readregexp = parse "/" { ("",readregexpoptions lexbuf) } | "\\/" { let (s,o) = readregexp lexbuf in ("/"^s,o) } | ([^'/' '\\']+ | '\\'[^'/'][^'/' '\\']*) { let s = Lexing.lexeme lexbuf in let (s',o) = readregexp lexbuf in (s^s',o) } and readregexpoptions = parse (['w' 'i']*) { let w = Lexing.lexeme lexbuf in let rec loop r i = if i = String.length w then r else loop ((match w.[i] with 'w' -> Ast.Word_boundary | 'i' -> Ast.Case_insensitive | _ -> assert false)::r) (i + 1) in loop [] 0 } and readident = parse alpha (alphanum|'_')* { Lexing.lexeme lexbuf } { (* Epilogue. *) } ara-1.0.31/libara/dpkg.mli0000644000000000000000000002532011553072337012117 0ustar module SS : sig type t = string * string val compare : 'a -> 'a -> int end module SSM : sig type key = SS.t type 'a t = 'a Map.Make(SS).t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module IM : sig type key = int type +'a t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module type BIG_SET = sig type t type u type v type elt = int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a val empty : t val union : t -> t -> t val diff : t -> t -> t val inter : t -> t -> t val add : int -> t -> t val cardinal : t -> int val is_empty : t -> bool val elements : t -> int list val create_compression_buffer : unit -> v val compress : v -> t -> u val decompress : v -> u -> t end module IS : BIG_SET module SM : sig type key = String.t type 'a t = 'a Map.Make(String).t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module SSet : sig type elt = String.t type t = Set.Make(String).t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t end val decompose_line : string -> string * string val first_non_space : string -> int class paragraph_folder : object method add_line : string -> unit method add_string : string -> unit method get : string method output : out_channel -> unit method reset : unit end type ('a, 'b, 'c) dbg = { m : int; db : 'c array array; fields : string array; display_names : string array; package_field : int; version_field : int; index : int SSM.t; universe : IS.t; extra : 'b; methods : 'a; } type ('a, 'b) load_context = { field_index : (string, int) Hashtbl.t; non_canonical_names : (string, string) Hashtbl.t; mutable field_count : int; read_buffer : Buffer.t; mutable package_count : int; mutable packages : (int * 'b) list list; mutable ctx_extra : 'a; } class line_reader : in_channel -> object val b : Buffer.t val mutable i : int val mutable j : int val mutable offset : int val u : string method get_offset : int method input_line_with_offset : (string * int * int) option method refill : unit method reset : unit end module type DBT = sig type extra type field class database_loader : object ('a) method create_load_context : (extra, field) load_context method display_name_of_field : ('a, extra, field) dbg -> int -> string method display_string_of_field : ('a, extra, field) dbg -> int -> string method empty_field : field method field_of_string : ('a, extra, field) dbg -> string -> int method find_package : ('a, extra, field) dbg -> string -> string -> int method get_count : ('a, extra, field) dbg -> int method get_display_names : ('a, extra, field) dbg -> string array method get_field : ('a, extra, field) dbg -> int -> int -> string method get_field_from_package : ('a, extra, field) dbg -> field array -> int -> string method get_fields : ('a, extra, field) dbg -> string array method get_package : ('a, extra, field) dbg -> int -> string array method get_universe : ('a, extra, field) dbg -> IS.t method is_field_empty : field -> bool method key : (extra, field) load_context -> field -> field -> string * string method key_of : ('a, extra, field) dbg -> int -> string * string method load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> ('a, extra, field) dbg method load_single_file : fast:bool -> ?progress:(string -> int -> unit) -> (extra, field) load_context -> string -> unit method name_of : ('a, extra, field) dbg -> int -> string method package_field : ('a, extra, field) dbg -> int method string_of_field : ('a, extra, field) dbg -> int -> string method version_field : ('a, extra, field) dbg -> int method version_of : ('a, extra, field) dbg -> int -> string end end class pf : paragraph_folder module Misc : functor (DBT : DBT) -> sig type db = (DBT.database_loader, DBT.extra, DBT.field) dbg class paragraph_folder : pf module IS : BIG_SET val field_of_string : db -> string -> int val string_of_field : db -> int -> string val display_name_of_field : db -> int -> string val display_string_of_field : db -> int -> string val name_of : db -> int -> string val version_of : db -> int -> string val key_of : db -> int -> string * string val find_package : db -> string -> string -> int val get_package : db -> int -> string array val get_field : db -> int -> int -> string val get_field_from_package : db -> DBT.field array -> int -> string val get_universe : db -> IS.t val get_fields : db -> string array val get_count : db -> int val get_display_names : db -> string array val package_field : db -> int val version_field : db -> int end module type DB = sig module IS : BIG_SET type db and field val field_of_string : db -> string -> int val string_of_field : db -> int -> string val display_name_of_field : db -> int -> string val display_string_of_field : db -> int -> string val name_of : db -> int -> string val version_of : db -> int -> string val key_of : db -> int -> string * string val find_package : db -> string -> string -> int val get_package : db -> int -> string array val get_field : db -> int -> int -> string exception Malformed_line of string val find_database_files : (string * string) list -> string list val load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> db val get_universe : db -> IS.t val get_fields : db -> string array val get_count : db -> int val get_display_names : db -> string array val package_field : db -> int val version_field : db -> int val backend : string class paragraph_folder : object method add_line : string -> unit method add_string : string -> unit method get : string method output : out_channel -> unit method reset : unit end end val create_load_context : 'a -> ('a, 'b) load_context val binary_search : 'a array -> 'a -> int exception Malformed_line of string val collect_field_values : ('a, 'b, SSet.elt) dbg -> int -> SSet.elt list val find_database_files : (string * string) list -> string list class virtual ['a, 'b, 'c] database : object ('d) method virtual create_load_context : ('a, 'b) load_context method display_name_of_field : ('d, 'a, 'b) dbg -> int -> string method display_string_of_field : ('d, 'a, 'b) dbg -> int -> string method virtual empty_field : 'b method field_of_string : ('d, 'a, 'b) dbg -> string -> int method find_package : ('d, 'a, 'b) dbg -> string -> string -> int method get_count : ('d, 'a, 'b) dbg -> int method get_display_names : ('d, 'a, 'b) dbg -> string array method virtual get_field : ('d, 'a, 'b) dbg -> int -> int -> string method virtual get_field_from_package : ('d, 'a, 'b) dbg -> 'b array -> int -> string method get_fields : ('d, 'a, 'b) dbg -> string array method virtual get_package : ('d, 'a, 'b) dbg -> int -> string array method get_universe : ('d, 'a, 'b) dbg -> IS.t method virtual is_field_empty : 'b -> bool method private virtual key : ('a, 'b) load_context -> 'b -> 'b -> string * string method key_of : ('d, 'a, 'b) dbg -> int -> string * string method load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> ('d, 'a, 'b) dbg method virtual load_single_file : fast:bool -> ?progress:(string -> int -> unit) -> ('a, 'b) load_context -> string -> unit method private virtual make_field : context:('a, 'b) load_context -> fast:bool -> file_id:'c -> start_offset:int -> end_offset:int -> field_name:string -> field_contents:string -> first_line:string -> 'b method virtual name_of : ('d, 'a, 'b) dbg -> int -> string method package_field : ('d, 'a, 'b) dbg -> int method private read_tags : ?fast:bool -> 'c -> ('a, 'b) load_context -> reader:line_reader -> (int * 'b) list method string_of_field : ('d, 'a, 'b) dbg -> int -> string method version_field : ('d, 'a, 'b) dbg -> int method virtual version_of : ('d, 'a, 'b) dbg -> int -> string end module V : sig type file and pool and virtual_string and t exception Error of string exception Not_real exception File_out_of_date of string end module DBFS : DB module DBRAM : DB ara-1.0.31/libara/syntax.mly0000644000000000000000000000615111553072336012540 0ustar %{ (* Syntax *) (* $Id: syntax.mly,v 1.7 2004/10/24 20:27:24 berke Exp $ *) (* Prolog *) open Ast %} %token EOF %token EQ %token NEQ %token LEQ %token GEQ %token LT %token GT %token MATCHES %token DOESNT_MATCH %token LPAREN %token RPAREN %token LBRACK %token RBRACK %token COLON %token COMMA %token AND %token TRUE %token FALSE %token NOT %token OR %token ASSIGN %token STAR %token PLUS %token COMMA %token IDENTITY %token REVERSE %token DOT %token TILDE %token IDENT %token STRING %token REGEXP %type statement %start statement %left OR %left AND %nonassoc ASSIGN %nonassoc NOT %nonassoc EQ %nonassoc NEQ %nonassoc MATCHES %nonassoc DOESNT_MATCH %left LT %left LEQ %left GT %left GEQ %nonassoc COLON %% statement : | IDENT ASSIGN set_query EOF { let s1 = Parsing.rhs_start 3 and s2 = Parsing.rhs_end 3 in Assign($1,s1,s2,$3) } | set_query EOF { Display($1) } relation : | IDENTITY { Identity } | relation AND relation { Intersection($1,$3) } | relation OR relation { Union($1,$3) } | NOT relation { Complement($2) } | relation STAR { Star($1) } | relation PLUS { Plus($1) } | relation REVERSE { Reverse($1) } | relation DOT relation { Compose($1,$3) } | LPAREN relation RPAREN { $2 } | field { Relation(Field_link($1)) } set_query : | LPAREN set_query RPAREN { $2 } | LBRACK relation RBRACK set_query { Meta(Apply_relation(Reverse($2)), $4) } | set_query LBRACK relation RBRACK { Meta(Apply_relation($3), $1) } | set_query AND set_query { And($1,$3) } | set_query set_query { And($1,$2) } | set_query OR set_query { Or($1,$3) } | NOT set_query { Not($2) } | TRUE { True } | FALSE { False } | REGEXP { let (x,y) = $1 in Atom(Matches(Current_field, Regular(x,y))) } | field MATCHES REGEXP { let (x,y) = $3 in Atom(Matches($1,Regular(x,y))) } | field DOESNT_MATCH REGEXP { let (x,y) = $3 in Not(Atom(Matches($1,Regular(x,y)))) } | field EQ STRING { Atom(Matches($1,Exact($3))) } | field NEQ STRING { Not(Atom(Matches($1,Exact($3)))) } | field LEQ STRING { Atom(Matches($1,Lexicographic_le($3))) } | field GEQ STRING { Atom(Matches($1,Lexicographic_ge($3))) } | field LT STRING { And(Not(Atom(Matches($1,Exact($3)))),Atom(Matches($1,Lexicographic_le($3)))) } | field GT STRING { And(Not(Atom(Matches($1,Exact($3)))),Atom(Matches($1,Lexicographic_ge($3)))) } | STRING { Atom(Matches(Current_field, Regular(Util.reg_of_string $1,[Case_insensitive]))) } | IDENT { Atom(Reference($1)) } | field_spec COLON set_query { Meta(With_field($1),$3) } field_spec : | field { $1 } | field COMMA field_spec { Either_field($1, $3) } field : | TILDE { Current_field } | STAR { Some_field(Regular("",[])) } | STRING { let w = $1 in try let m = String.length w in let b = Buffer.create m in Buffer.add_char b '^'; for i = 0 to m - 1 do match w.[i] with | ('.'|'+'|'?'|'['|']'|'^'|'$'|'\\') as c -> Buffer.add_char b '\\'; Buffer.add_char b c | '*' -> Buffer.add_string b ".*" | c -> Buffer.add_char b (Char.lowercase c) done; Buffer.add_char b '$'; Some_field(Regular(Buffer.contents b,[Case_insensitive])) with | Not_found -> This_field($1) } ara-1.0.31/libara/versions.lst0000644000000000000000000000115411553072337013062 0ustar # List of # ver1 ver2 ret # Of versions worth testing # 1 means that ver1 > ver2 # -1 means that ver1 < ver2 # 0 means that ver1 = ver2 7.6p2-4 7.6-0 1 1.0.3-3 1.0-1 1 1.3 1.2.2-2 1 1.3 1.2.2 1 # Important attributes - . -1 p - -1 a - -1 z - -1 a . -1 z . -1 # Epochs 1:0.4 10.3 1 1:1.25-4 1:1.25-8 -1 # Junk 1:1.2.13-3 1:1.2.13-3.1 -1 2.0.7pre1-4 2.0.7r-1 -1 # Test some properties of text strings 0-pre 0-pre 0 0-pre 0-pree -1 1.1.6r2-2 1.1.6r-1 1 2.6b2-1 2.6b-2 1 98.1p5-1 98.1-pre2-b6-2 -1 0.4a6-2 0.4-1 1 1:3.0.5-2 1:3.0.5.1 -1 # #194327 III-alpha9.8 III-alpha9.8-1.5 -1 # #205960 3.0~rc1-1 3.0-1 -1 ara-1.0.31/common/0000755000000000000000000000000011553101133010506 5ustar ara-1.0.31/common/help.ml0000644000000000000000000002405211553072334012005 0ustar (* Help *) (* $Id: help.ml,v 1.2 2004/10/24 20:27:24 berke Exp $ *) (* :vim:set tw=75: *) (*** about *) let about = Printf.sprintf "\ This is ara version %s released on %s. Written by Oguz Berke DURAK (http://abaababa.ouvaton.org/). Copyright (C) 2004. Released under the GNU General Public Licence version 2. Many thanks to George Danchev, Thomas Schoepf and Sven Luther for doing the Debian packaging of ara and many helpful comments. " Version.version Version.date ;; (* ***) (*** gui_about *) let gui_about = Printf.sprintf "Xara version %s released on %s\n\ by OÄŸuz Berke DURAK\n\ (http://abaababa.ouvaton.org/)\n\ Copyright (C) 2004-2005\n\n\ Released under the GNU General Public Licence version 2.\n\n\ Many thanks to George Danchev, Thomas Schoepf and\n\ Sven Luther for doing the Debian packaging of ara and\n\ many helpful comments.\n\n\ http://ara.alioth.debian.org\n\ " Version.version Version.date ;; (* ***) (*** syntax *) let syntax = "\ Queries are made up of terms, which are words (or regular expressions) used to select matching packages. By default, terms are searched in the Description field of packages. BOOLEAN OPERATORS The query apache selects all packages which have the word Apache or apache (or any other capitalization) in their Description field, whereas apache & php4 selects those having both apache and php4. Words containing spaces or special characters can be enclosed in \" double quotes. The boolean operators are | (disjunction) which can be also be written OR, & (conjunction) which can be written AND, and ! (complementation) which can be written NOT. Expressions can be grouped using parentheses. Example : (debian | \"gnu/linux\") and not (kde or gnome) FIELD QUALIFIERS Instead of the Description field, you can search other fields by preceding the search term with the name of the field followed by a colon, as in : depends:ocaml In fact this changes the default search field and applies to the following term even when it is a complex term. For example depends:(kde or gnome or x11 or qt) & section:graphics will select all packages whose Depends field contains kde, gnome, x11 or qt and whose Section field contains graphics. The field qualifier can be a star-expression. This way you may type : d*:(something or \"something else\") and this will return all packages having something or something else in any field whose name starts with a d. REGULAR EXPRESSIONS More complex regular expressions need to be enclosed between slashes /. The syntax is sed-ish, the second slash can be followed by i for case-insensitivity and w for word-boundary enforcing. (Remark: digits count as word boundaries). The regular expression syntax is that of Ocaml's Str module, which is more or less standard. Example : /[tpn]etris/iw & depends:/libqt.*/w VARIABLES It is possible to put the result of a query into a named variable and use that variable afterwards. This is accomplished by including an assignment in the query, such as : $gui := depends:(gtk | qt | kde | gnome | xlibs) After execution a variable named GUI will appear in the variable list. It may then be referred as $gui. Variables are currently not saved. OTHER OPERATORS There are lexicographic comparison operators <, >, <= and >=. These use the Debian version order, which implies that version numbers and unsigned numbers in radixes <= 10 can be compared meaningfully. Example : size >= 50000 Note that these do not work well with version numbers. Equality = and difference <> are also defined. OLDER ARA SYNTAX The old syntax used in ara is still fully supported, and I plan to keep it around for a while. Note that there have been some changes in Ocaml's Str module regular expression syntax recently (this concerns things like word boundaries). NOTES Some syntax involving brackets [ ] has been alloted for not yet implemented relational operators. Executing such queries will give an harmless error. ";; let examples = "\ This is ara, a utility to search the Debian (a Linux distribution) package database using boolean combinations of regular expressions operating on fields of the description. ara is written in Ocaml, the finest computer programming language on the surface of the earth. See http://caml.inria.fr/ for details. See the manual page for details. EXAMPLES ara -list 'section=utils' List the name of every package in section utils. ara -list 'section=utils and not depends:(gnome or kde or gtk)' ... except those whose dependency field contains gnome or kde or gtk ara -set 'section=utils and not depends:(gnome|kde|gtk) & priority=optional' ... list multiple names per line, and show only optional packages. ara -set 'section=utils & !depends:(gtk|gnome|kde) & priority=optional & size<100000' ... exclude packages greater than 99999 bytes. ara -set 'section=utils & (!Depends=~/gtk\\|gnome\\|kde/ | Size<100000) & Priority=optional' ... well, exclude gtk,gnome or kde stuff only if 100000 bytes or greater. ara -fields Package,Size,Maintainer:20 -table 'section=utils & (!depends:(gtk|gnome|kde) | size<100000) & priority=optional' ... show Package, Size and Maintainer fields from the above results as a nice ascii table, limiting the maintainer field to 20 characters. ara -fields Package:8,Size,Description:100 -table 'section=games & !depends:(gtk|sdl|kde|opengl|gnome) & !description:(/shoot|kill|destroy|blast|race|bomb/iw | /multi\\(-\\|\\)player\\|strategy\\|conquest\\|3\\(-\\|\\)d/iw) & depends:(xlibs|vga) & !size>1000000' Assuming a 125-column display, display the first eight characters of the package name, the size in bytes, and the first hundred characters of the description of all packages in the games section not exceeding one million bytes, not depending on fancy stuff like gtk,SDL,KDE,OpenGL or Gnome, not mentioning some forms of violence (to shoot, to kill, etc.) in its description, not described as multi-player, strategy, conquest or three-dimensional games, yet depending on either xlibs or svga to exclude console-based games. SPEED ara reads the whole database into memory and then processes queries. Since the database is usually big, this takes some time. However, queries then run quite fast. So : specify multiple queries or use the -interactive option to amortize the cost of reading the database. REMARKS The database lives, by default, as text files under /var/lib/apt/lists/* or /var/lib/dpkg/available on your Debian installation. It lists all packages, installed or not, that are known to your Debian package management system. Searching this file using grep usually gives bad results. This utility has been written out of the frustration of not being able to do satisfactory searches using standard text processing tools.\n" ;; (* ***) (*** cli_help *) let cli_help = " GENERAL OPERATION Type your query and press enter. Ara will display packages matching your query using the current display mode. If the results are longer than what your screen can handle, ara will pipe the output to a pager, which is /etc/alternatives/pager by default. Depending on your system, this will be probably a link to /usr/bin/less or /bin/more : to quit the pager and return to ara, press 'q'. Type #syntax for help on syntax, #examples to see some examples, #quit, #bye, #q or CTRL-D (EOF) to quit, #version to see version information, #about to see copyright, thanks and dedication, #memory to see memory usage, #compact to compact the heap, DISPLAY AND ACTION MODES In the following, if [query] is omitted, the default action mode is changed instead : #short [query] to display results in short form #list [query] to display results as a list of package (and version) names #table [query] to display results as a table #show [query] to show results in unformatted form #raw [query] same #all [query] same as above, but will always show all fields #ast [query] to display the abstract syntax tree #install [query] to install packages in query. If a package is listed more than once, it will only install the newest version. #remove [query] to remove packages in query REDIRECTIONS AND PRINTING Output from the commands #short, #list, #table, #show and #ast can be redirected to a file or to the printer as follows : (examples shown with #short, which can be omitted, in which case the current mode is used) >/path/file #short [query] will write output to file /path/file >>/path/file #short [query] will append output to file /path/file >|/path/file #short [query] will overwrite file /path/file with output #print #short [query] will print output using the configuration value cli.commands.print All meaningful command-line options can be changed interactively by typing : #set [options] [queries] to change options and launch queries #set help to display list of options Dashes preceding option keywords can be omitted. MISCELLANEOUS COMMANDS APT commands: #update to launch apt-get update (type #reload afterwards) #upgrade to launch apt-get upgrade #dist-upgrade to launch apt-get dist-upgrade Other commands : #reload to reload the database #shell to launch a shell #compact to compact the heap #memory to show memory usage (Press 'q' to quit this pager and return to ara.) ";; (* ***) (*** cli_examples *) let cli_examples = "\ Example 1 #fields package,maintainer:30,version:20 #table section=utils & (!depends:(gtk|gnome|kde) | size<100000) & priority=optional Example 2 section=utils and status:/^install/ Example 3 section=utils & (!depends:(gtk|gnome|kde) | size<100000) & priority=optional Example 4 #set new #set borders #set fields Package:20,Version:10,Status:10,Description:35 #table section=games & (/[^ ]etris/i or /fall.* block/) T := section=games & (/[^ ]etris/i or /fall.* block/) T & !depends:(kde or qt or gnome or emacs) >/tmp/tetrises.txt T & !depends:(kde or qt or gnome or emacs) #bye ";; (* ***) ara-1.0.31/common/Makefile0000644000000000000000000000037011553072335012161 0ustar # $Id: Makefile.ara,v 1.1 2004/10/26 09:44:54 berke Exp $ BASE = .. LIB = common LIBS = SOURCES = version.mli version.ml help.mli help.ml EXTRA_CLEAN = version.ml include Makefile.library version.ml: version.ml.tpl mkversion.sh ./mkversion.sh ara-1.0.31/common/mkversion.sh0000755000000000000000000000035311553072334013075 0ustar #!/bin/sh VERSION=`sed -n -e '1s/^ara (\([^ ]*\)) .*$/\1/p' ../debian/changelog` DATE=`date +'%04Y-%02m-%02d'` rm -f version.ml sed -e 's/\$VERSION\$/'"$VERSION"'/g' \ -e 's/\$DATE\$/'"$DATE"'/g' \ version.ml.tpl >version.ml ara-1.0.31/common/version.ml.tpl0000644000000000000000000000011311553072335013331 0ustar (* Version *) (* $Id$ *) let version = "$VERSION$" let date = "$DATE$" ;; ara-1.0.31/common/version.mli0000644000000000000000000000004711553072334012711 0ustar val version : string val date : string ara-1.0.31/common/help.mli0000644000000000000000000000020411553072335012150 0ustar val about : string val gui_about : string val syntax : string val examples : string val cli_help : string val cli_examples : string ara-1.0.31/etc/0000755000000000000000000000000011553101133007771 5ustar ara-1.0.31/etc/ara.config0000644000000000000000000000122511553072340011732 0ustar (* System-wide default configuration file for Ara *) ara { database { paths: [("/var/lib/dpkg/", "^available$"); ("/var/lib/apt/lists/", "_Packages$"); ("/var/lib/apt/lists/", "_Sources$"); ("/var/lib/dpkg/", "^status$")] } commands { pager: "/etc/alternatives/pager" run_interactive_command: "/usr/bin/sudo ${COMMAND}" install: "/usr/bin/apt-get install ${PACKAGE}=${VERSION}" remove: "/usr/bin/apt-get remove ${PACKAGE}=${VERSION}" update: "/usr/bin/apt-get update" upgrade: "/usr/bin/apt-get upgrade" dist_upgrade: "/usr/bin/apt-get dist-upgrade" print: "/usr/bin/a2ps -q" } } ara-1.0.31/etc/xara.config0000644000000000000000000000122211553072340012117 0ustar (* System-wide default configuration file for Xara *) xara { database { paths: [("/var/lib/dpkg/", "^available$"); ("/var/lib/apt/lists/", "_Packages$"); ("/var/lib/apt/lists/", "_Sources$"); ("/var/lib/dpkg/", "^status$")] } commands { run_interactive_command: "/etc/alternatives/x-terminal-emulator -e /usr/bin/sudo ${COMMAND}" install: "/usr/bin/apt-get install ${PACKAGE}=${VERSION}" remove: "/usr/bin/apt-get remove ${PACKAGE}=${VERSION}" update: "/usr/bin/apt-get update" upgrade: "/usr/bin/apt-get upgrade" dist_upgrade: "/usr/bin/apt-get dist-upgrade" print: "/usr/bin/a2ps -q" } } ara-1.0.31/etc/ara-httpd.config0000644000000000000000000000034311553072340013053 0ustar (* System-wide default configuration file for Ara HTTPD *) ara_httpd { database { paths: [("/var/lib/dpkg/", "^available$"); ("/var/lib/apt/lists/", "_Packages$")] } interface.stylesheet: "default.css" } ara-1.0.31/etc/xara-gtkrc-2.00000644000000000000000000000021011553072340012254 0ustar # LablGTK2 is known to crash with some Qt GTK2 rendering engines. # style "default" { engine "" { } } class "GtkWidget" style "default" ara-1.0.31/doc/0000755000000000000000000000000011553101133007763 5ustar ara-1.0.31/doc/Makefile0000644000000000000000000000034111553072340011430 0ustar # Makefile .PHONY: all all: ara.1 xara.1 ara.1: ara.m4 m4 -D"m4_ara=ara" -P ara.m4 | sed -e "s/'/'/g" >ara.1 xara.1: ara.m4 m4 -D"m4_ara=xara" -P ara.m4 | sed -e "s/'/'/g" >xara.1 clean: @rm -f ara.1 xara.1 ara-1.0.31/doc/ara.m40000644000000000000000000006257411553072340011015 0ustar .\" manual page [] for m4_ara() .\" SH section heading .\" SS subsection heading .\" LP paragraph .\" IP indented paragraph .\" TP hanging label .TH m4_translit(m4_ara(),'a-z','A-Z') 1 "November 1, 2004" .SH NAME m4_ifelse(m4_ara, `ara', `ara \- a utility for doing boolean regexp queries on the the Debian package database', `xara \- GTK2 interface for the above') .SH SYNOPSIS m4_ifelse(m4_ara, `ara', `.SS Batch mode: .B ara [options] query .LP In batch mode, \fBara\fP takes one or more queries as arguments, read the database files according to its configuration, and outputs the results to \fBstdout\fP. .SS Interactive mode: .B ara [options] \-i .LP With the \fB\-i\fP or \fB\-interactive\fP options, \fBara\fP reads the database files and then prompts the user for queries or commands. The results are displayed (with the help of a pager such as \fBmore\fP or \fBless\fP if necessary), and \fBara\fP prompts the user again. Interactive mode is strongly recommended, since loading the package databases can be long, but once loaded, queries run quite fast. This is a major advantage of \fBara\fP over tools such as \fBdpkg\-iasearch\fP or \fBdpkg\-dctrl\fP. For key bindings see \fBKEY BINDINGS\fP. .SS Graphical interface (GTK2): A graphical interface, \fBxara(1)\fP, is provided by the Debian package \fBxara-gtk\fP.', `.SS Graphical interface (GTK2): .B xara .LP The graphical interface allows the user to input queries and browse the results. Menu options are provided for installing and removing the selected packages using \fBapt\-get\fP. The packages the user is interested in may be bookmarked. Command-line interface (GTK2): A command-line interface, \fBara(1)\fP, is provided by the Debian package \fBara\fP.') .SS Query syntax See the \fBEXAMPLES\fP section for a quick introduction ; \fBxara\fP has some built\-in help. The syntax is described in detail below. .SH DESCRIPTION .LP .B ara and .B xara allow the user to search the Debian software package database (which includes installed and uninstalled packages) using powerful queries made of boolean combinations of regular expressions acting on fields given by patterns. For example, the query \fB section=utils & depends:(gtk or tk8 or xlibs or kde or gnome or qt) & debian & package \fP will display packages in the section \fButils\fP that have graphical interfaces (because they depend on graphical toolkits or X11 libraries), and whose description contains the words \fBdebian\fP and \fBpackage\fP. .SH RATIONALE .LP Debian users can easily install software with the commands \fBdselect\fP or \fBapt\-get install\fP. They can choose (on Debian 3.1 unstable) from over 30,000 packages. Finding the right package can be quite difficult. Although packages are categorized in crude sections, there are still too many packages and reading all descriptions is out of the question. The database files are huge and their mail\-like syntax makes them hard to search with line\-oriented tools like grep. There exist commands such as \fBdpkg\-iasearch\fP(1) or \fBdpkg\-dctrl\fP(1) but their capabilities are limited. Graphical package management tools such as \fBaptitude\fP or \fBsynaptic\fP have search capabilities. Although \fBara\fP can call \fBapt\fP to install or remove packages, its orientation is that of a powerful search tool. Indeed, the name \fBara\fP comes from the imperative form of the Turkish verb \fBaramak\fP which means "to search". .SH THE DEBIAN PACKAGE DATABASE .LP The database of Debian packages is a huge text file at \fB/var/lib/dpkg/available\fP (or a collection of text files under \fB/var/lib/apt/lists/\fP). These files are in a mailbox\-like format, and a typical entry looks like this: .nf Priority: required Section: base Installed\-Size: 460 Origin: debian Maintainer: Dpkg Development Bugs: debbugs://bugs.debian.org Architecture: i386 Source: dpkg Version: 1.10.24 Replaces: dpkg (<< 1.10.3) Depends: libc6 (>= 2.3.2.ds1\-4), .... Filename: pool/main/d/dpkg/dselect_1.10.24_i386.deb Size: 119586 MD5sum: c740f7f68dab08badf4f60b51a33500a Description: a user tool to manage Debian packages dselect is the primary user interface for installing, removing and managing Debian packages. It is a front\-end to dpkg. .LP Each package is thus described by a set of fields (like Package, Description, Version...). .SH QUERY SYNTAX AND SEMANTICS .LP Here we describe the query syntax in some detail. As of version 1.0, \fBara\fP introduces new, simplified syntax which is quite traditional and should be familiar to anyone having used search engines. Search terms are simply combined with \fBAND\fP, \fBOR\fP and \fBNOT\fP boolean operators. Having a look at the \fBEXAMPLES\fP section at the end of this manual should provide you a starting point. Consider the set \fBD\fP of Debian package descriptions contained in the file \fB/var/lib/dpkg/available\fP (or in files under \fB/var/lib/apt/lists/\fP). Each description is a set of couples of the form \fB(f,v)\fP where \fBf\fP and \fBv\fP are strings: \fBf\fP is the name of the field (namely, \fBPackage\fP, \fBDescription\fP, \fBFilename\fP, \fBDepends\fP, etc.); \fBv\fP is its value. Thus \fBD\fP is a set of set of couples, forming the universe. Queries select subsets of the universe \fBD\fP. Output options select which fields of the selected part of the universe to display, and how to display them. .SS Queries A \fBquery\fP is a boolean combination of atomic expressions. An \fBatomic expression\fP selects a subset of the set \fBD\fP of descriptions. I call this set the \fBmeaning\fP of the expression; if \fBe\fP denotes an atomic expression, its meaning is denoted by \fB[e]\fP. The meaning of a boolean combination of atomic expressions is just the boolean combination of the meaning of its constituents. In other words, if \fBe1\fP and \fBe2\fP are atomic expressions, then \fBe1 & e2\fP is a query, whose meaning is the intersection of the meanings of \fBe1\fP and \fBe2\fP; and the meaning of \fBe1 | e2\fP is the union of the meanings of \fBe1\fP and \fBe2\fP. .SS Atomic expressions Atomic expressions can be of the forms \fBpattern\fP, \fB/regexp/\fP, \fBquoted_string\fP, \fBfieldspec operator1 string\fP, or \fBfieldspec operator2 regexp\fP. .SS Boolean operators and constants .TP \fBe1 & e2\fP (also \fBe1 AND e2\fP, \fBe1 and e2\fP) This is logical conjunction (set intersection). Returns the intersection of [e1] and [e2], i.e. packages satisfying both e1 and e2. .TP \fBe1 | e2\fP (also \fBe1 OR e2\fP, \fBe1 or e2\fP) This is logical disjunction (set union). Union of [e1] and [e2], i.e. packages satisfying e1, e2 or both. .TP \fB!e1\fP (also \fBNOT e1\fP, \fBnot e1\fP) This is logical negation (set complementation). Complement of [e1], i.e. packages not satisfying e1. Please note that \fB~\fP stands for the current default field specifier and is not an alias for the complementation operator. .TP \fBtrue\fP (also \fBall\fP) The set of all descriptions, i.e. all packages. .TP .B \fBfalse\fP (also \fBnone\fP) The empty set, i.e. no packages. .SS Field specifiers A field specifier \fBfieldspec\fP is a comma\-separated list of field patterns. Field patterns are like simple shell patterns and they may contain star characters (which stand for anything) or question marks (which stand for any single character). They are case\-insensitive. They specify a set of fields. For example \fBdescription\fP and \fBDescription\fP specify the set of fields \fB{ Description }\fP, whereas \fBde*\fP specifies \fB{ Description, Depends }\fP. The special specifier \fB~\fP denotes the current default specifier (see below). .SS Current fields specifiers and simplified atomic expressions The need to repeat the field specifier can make the above syntax cumbersome. That is why there is a \fBcurrent field specifier\fP. The current field specified is, by default, \fBDescription,Package\fP. Simplified atomic expressions are simply words or simplified shell expressions (which do not need to be enclosed in double quotes) and they are searched in fields in the current field specifier. They can be made of letters, digits, underscores, dashes and periods. They may contain stars of question marks which are interpreted as for field patterns (i.e., as simplified shell expressions). If double quotes are used, other characters and spaces can be used. The default field specifier in a query \fBquery\fP can be changed to \fBfieldspec\fP by simply prefixing the query with \fBfieldspec:\fP. This gives \fBfieldspec:query\fP. However if \fBquery\fP is complex (i.e., contains binary boolean operators) you need to enclose \fBquery\fP in parentheses, as in \fBfieldspec:(query1 or query2)\fP. .SS String literals \fBString literals\fP can be given with or without double quotes; without double quotes, the syntax is as for C identifiers, except that you can use dashes, you must start with a latin letter (\fB[a\-zA\-Z]\fP) and you can continue with Latin letters, decimal digits or underscore (\fB[a\-zA\-Z0\-9_]\fP). Inside double quotes, all characters are allowed, except double quotes, which must be preceded by a backslash. .SS Variables Results of queries can be stored in variables, which may be recalled later. This isn't very useful in batch mode but is useful in interactive and graphical modes. Variable names start with a dollar and follow usual conventions for variables, i.e., they can be any mix of alphanumeric characters and symbols such as underscore, dash, etc. Variable names are case\-sensitive so that \fB$Installed\fP and \fB$installed\fP are different. To assign the result of a query (which is a set of packages) a variable named \fB$variable\fP just execute the query \fB$variable := query\fP. You may then recall this particular set by simply writing \fB$variable\fP. Example: \fB$installed := status:(installed & !not\-installed)\fP .SS Operators Hierarchical comparison operators can be negated by changing the direction of the angle brackets and adding or removing an equality sign at end (\fB<=\fP becomes \fB>\fP). Other operators are negated as follows: \fB=\fP becomes \fB!=\fP and \fB=~\fB becomes \fB!~\fP. .TP .B fieldspec=string Atomic expression selecting packages having a field in \fBfieldspec\fP having a value a value exactly equal to \fBstring\fP. .TP .B fieldspecstring, fieldspec>=string) Atomic expression selecting packages having a field in \fBfieldspec\fP whose value is strictly less than \fBstring\fP. The order used is the Debian versioning order. This order is compatible with the natural order on integers and with Debian version numbers. When comparing strings not containing special characters, letters sort before numbers, as opposed to lexicographic ASCII order we are used to. This means that hexadecimal numbers (such as MD5 sums) will not have their usual order. Note that \fBstring\fP must be on the right side of the operator (i.e., you cannot write \fB1000 < Size\fP). .TP \fBfieldspec=~/expression/\fP (also \fBfieldspec:/expression/\fP) Selects descriptions whose field named \fBfieldspec\fP exists and whose value matches, case\-sensitively, the regular expression \fBexpression\fP. .TP .B \fBfieldspec=~/expression/i\fP (also \fBfieldspec:/expression/i\fP) Same as above, but the regular expression is case\-insensitive. .TP .B \fBfieldspec=~/expression/w\fP (also \fBfieldspec:/expression/w\fP) Same as above, but the regular expression is case\-sensitive and matches only at word boundaries. Note that letters\-to\-digit or digit\-to\-letter transitions are considered to be word boundaries. .TP .B \fBfieldspec=~/expression/iw\fP (also \fBfieldspec:/expression/iw\fP) The regular expression here is case\-insensitive and matched at word boundaries. .SS Regular expressions Regular expressions are given between a pair of slashes; the last slash can be followed by a commutative sequence of letters denoting flags. Regular expression syntax is sed\-like: grouping parentheses and alternation must be backslashed. For more details, see the Objective Caml manual chapter on the Str module. In short (\fBx\fP,\fBx1\fP,\fBx2\fP are meta\-symbols denoting regular expressions): .TP .B /./ Any character. .TP .B /toto/ Literal string toto. .TP .B /x1x2/ Concatenation. .TP .B /x1\\|x2/ Alternation. .TP .B \\(x1\\)* Star closure. .TP .B [c\-d] Character range. .TP .B \\b Word boundaries. .TP .B /x/i Case insensitive. .TP .B /x/w At word boundaries. .SS Remark Most queries will contain an appreciable amount of shell metacharacters. For example, logical disjunction is denoted by the pipe character, which is used by all known shells. The problem is aggravated by the fact that names of real commands are likely to appear in the used expressions; successfully setting up a UNIX pipeline by error is therefore plausible. When calling \fBara\fP from the command line in batch mode, You are strongly urged to protect your queries by surrounding them with simple quotes; never write something like \fBara Pack*=~/halt|reboot|shutdown/\fP as this will very likely reboot your system (and is incorrect regular expression syntax, if \fBhalt\fP or \fBreboot\fP or \fBshutdown\fP is meant: pipes must be backslashed). Instead, one should write .B ara 'Pack*=~/halt\\|reboot\\|shutdown /' .SH OPTIONS m4_ifelse(m4_ara,`ara', `.SS Operation .TP \fB\-interactive\fP, \fB\-i\fP Interactive mode ; prompt for a query, display it. .TP \fB\-config \fP (also for \fBxara\fP) Set configuration file name (default \fB$HOME/.ara/ara.config\fP). .TP \fB\-noconfig\fP Don`'t attempt to create a configuration file. .TP \fB\-nohistory\fP Don`'t save command history .SS Help options .TP \fB\-help\fP (also for \fBxara\fP) Display some help \fB\-about\fP Display copyright, thanks and dedication. .TP \fB\-version\fP, \fB\-about\fP (also for \fBxara\fP) Print author, license, version and dedication (and exit if called from CLI). .TP \fB\-examples\fP Display some documentation including examples exit. .TP \fB\-q \fP Query (e.g., depends:xlibs & !package:xcalc). .TP \fB\-query \fP Ditto. .SS Options pertaining to the terminal .TP \fB\-progress\fP (\fB\-noprogress\fP) Show or don`'t show progress indicator when loading database. .TP \fB\-lines \fP Set height of terminal for interactive display. By default this is taken from the environment variable \fBLINES\fP or as 25 if it is undefined. .TP \fB\-columns \fP Set width of terminal for interactive display. By default this is taken from the environment variable \fBCOLUMNS\fP or as 25 if it is undefined. .TP \fB\-pager\fP (\fB\-nopager\fP) Use (or don`'t use) a pager displaying long output in interactive mode. The pager command is defined in the configuration file \fB$HOME/.ara/ara.config\fP. By default this is \fB/etc/alternatives/pager\fP. The pager is only used when the output size exceeds the terminal height. .TP \fB\-debug\fP (also for \fBxara\fP) Enable debugging information .TP \fB\-debug\-level\fP (also for \fBxara\fP) Set debugging level (higher is more verbose, max is 100, default is 10) .SS Display styles \fB\-new\fP Show only newest version of each package. .TP \fB\-old\fP List all versions of packages. .TP \fB\-short \fP Display names of packages satisfying query (and their version if \fB\-old\fP is set), with multiple packages per line. .TP \fB\-list \fP Same, but display one package name per line, and no curly braces (default). .TP \fB\-raw \fP For each package satisfying the query, display all selected fields. .TP \fB\-table \fP Display results as a table. .TP \fB\-noborders\fP Don`'t draw ASCII borders for tabular output. .TP \fB\-borders\fP Draw ASCII borders for tabular output. .TP \fB\-count \fP Display number of matching packages. .TP \fB\-fields\fP Limit output to specified fields. The optional width specifiers are used with the \fB\-table\fP option and ignored otherwise. Use * to display all fields (but remember to escape the star character from your shell). .TP \fB\-ast\fP Dump the abstract syntax tree of parsed queries to stderr.', `None.') m4_ifelse(`m4_ara', `ara', `.SH INTERACTIVE MODE .SS General operation Type your query and press enter. \fBAra\fP will display packages matching your query using the current display mode. If the results are longer than what your screen can handle, ara will pipe the output to a pager, which is \fB/etc/alternatives/pager\fP by default. Depending on your system, this will be probably a link to \fB/usr/bin/less\fP or \fB/bin/more\fP : to quit the pager and return to \fBara\fP, press `'q'`. .SS Miscellaneous commands .TP \fB#syntax\fP Displays help on syntax. .TP \fB#examples\fP Displays some examples. .TP \fB#quit\fP, \fB#bye\fP, \fB#q\fP or \fBCTRL\-D\fP (EOF) Quits \fBara\fP. .TP \fB#version\fP To see version information. .TP \fB#about\fP To see copyright, thanks and dedication. .TP \fB#reload\fP To reload the database. .TP \fB#update\fP To launch \fBapt\-get update\fP (type \fB#reload\fP afterwards). .TP \fB#shell\fP or \fB!\fP To launch a shell. .LP .SS Display modes In the following, if [query] is omitted, the default action mode is changed instead : .TP \fB#short [query]\fP to display results in short form .TP \fB#bourbaki [query]\fP same .TP \fB#list [query]\fP To display results as a list of package (and version) names. .TP \fB#table [query]\fP To display results as a table. .TP \fB#show [query]\fP To show results in unformatted form. .TP \fB#raw [query]\fP Same. .TP \fB#all [query]\fP Same as above, but will always show all fields. .TP \fB#ast [query]\fP To display the abstract syntax tree. .TP \fB#install [query]\fP To install packages in query. If a package is listed more than once, it will only install the newest version. .TP \fB#remove [query]\fP To remove packages in query. .SS Redirection Output from the commands \fB#short\fP, \fB#list\fP, \fB#table\fP, \fB#show\fP and \fB#ast\fP can be redirected to a file as follows: (examples shown with \fB#short\fP) .TP \fB>/path/file #short [query]\fP Will write output to file \fB/path/file\fP. .TP \fB>>/path/file #short [query]\fP Will append output to file \fB/path/file\fP. .TP \fB>|/path/file #short [query]\fP Will overwrite file \fB/path/file\fP with output. .SS Key bindings The line editor \fBledit(1)\fP has been incorporated into \fBara\fP. Here are its key bindings. In the following lines, the caret sign "^" means "control" and the sequence "M\-" means "meta" (either with the "meta" prefix, or by pressing the "escape" key before). Examples: .TP 1.0i ^a press the "control" key, then press "a", then release "a", then release "control". .TP M\-a press the "meta" key, then press "a", then release "a", then release "meta", or: press and release the "escape" key, then press and release "a" (the manipulation with "meta" may not work in some systems: in this case, use the manipulation with "escape"). .PP The editing commands are: .nf ^a : beginning of line ^e : end of line ^f : forward char ^b : backward char M\-f : forward word M\-b : backward word ^p : previous line in history ^n : next line in history M\-< : first line in history M\-> : last line in history ^r : reverse search in history (see below) ^d : delete char (or EOF if the line is empty) ^h : (or del or backspace) backward delete char ^t : transpose chars M\-c : capitalize word M\-u : upcase word M\-l : downcase word M\-d : kill word M\-^h : (or M\-del or M\-backspace) backward kill word ^q : insert next char M\-/ : expand abbreviation ^k : cut until end of line ^y : paste ^u : line discard ^l : clear screen ^g : abort prefix ^c : interrupt ^z : suspend ^\\ : quit return : send line ^x : send line and show next history line other : insert char .fi The arrow keys can be used, providing your keyword returns standard key sequences: .nf up arrow : previous line in history down arrow : next line in history right arrow : forward char left arrow : backward char .SS Reverse search The reverse search in incremental, i.e. \fIledit\fP backward searches in the history a line holding the characters typed. If you type "a", it searches the first line before the current line holding an "a" and displays it. If you then type a "b", its search a line holding "ab", and so on. If you type ^h (or backspace), it returns to the previous line found. To cancel the search, type ^g. To find another line before holding the same string, type ^r. To stop the editing and display the current line found, type "escape" (other commands of the normal editing, different from ^h, ^g, and ^r stop the editing too). Summary of reverse search commands: .nf ^g : abort search ^r : search previous same pattern ^h : (or backspace) search without the last char del : search without the last char any other command : stop search and show the line found .fi ',`') m4_ifelse(m4_ara,`ara', `m4_define(`m4_example',`\fBara $1'$2'\fP')', `m4_define(`m4_example', `\fB$2\fP')') .SH EXAMPLES .TP .B m4_example(`',`Section=utils') List the name of every package in section utils. .TP .B m4_example(`',`Section=utils and !Depends:(gnome|kde|gtk)') ... except those whose dependency field matches the regexp gnome\\|kde\\|gtk .TP .B m4_example(`\-list ', `Section=utils and Status:(installed & !not\-installed)') List all installed packages in section \fButils\fP. .TP .B m4_example(`\-short ', `section=utils and !depends:(gtk|gnome|kde) and priority=optional') m4_ifelse(m4_ara,`ara', ` ... list multiple names per line, and show only optional packages.', ` ... show only optional packages.') .TP .B m4_example(`\-short ',`section=utils & (!depends:(gtk|gnome|kde) | size<100000) & priority=optional') Well, exclude gtk,gnome or kde stuff only if 100000 bytes or greater. m4_ifelse(m4_ara, `ara', `.TP .nf m4_example(`\-noborders \-fields Package,Size,Maintainer:20 \-table \\ \fB \-short ',`section=utils & (!depends:(gtk|gnome|kde) | size<100000) & priority=optional') \fP .fi .LP ... show Package, Size and Maintainer fields from the above results as a nice ascii table, limiting the maintainer field to 20 characters, but without crude ASCII borders.', `') .TP .nf m4_example(`\-old \-fields Package:8,Size,Description:100 \\ \fB \-table ', `Section=games and not (Depends:(gtk|sdl|kde|opengl|gnome|qt) \fB or /shoot\\|kill\\|destroy\\|blast\\|race\\|bomb/iw \fB or /multi\\(\-\\|\\)player\\|strategy\\|conquest\\|3\\(\-\\|\\)d/iw) \fB and Depends:(xlibs or vga) \fB and Size <= 1000000') \fP .fi .LP m4_ifelse(m4_ara, `ara', `Assuming a 125\-column display, display the first eight characters of the package name, the size in bytes, and the first hundred characters of the (first line) of the description of ', `Display ') all packages in the games section whose size does not exceeding one million bytes, and which do not depend on fancy stuff like GTK, SDL, KDE, OpenGL, Qt or Gnome, do not mention some form of violence (to shoot, to kill, etc.) in their description, are not described as multi\-player, strategy, conquest or three\-dimensional, and yet depend on either xlibs or svga to exclude console\-based games. .SH SPEED .B m4_ara reads the whole database into memory and then processes queries. Since the database is usually big, this takes some time. However, queries then run quite fast. So specify multiple queries or use the \fB\-interactive\fP option to amortize the cost of reading the database. .SH LICENSE .B m4_ara is released under the GNU General Public License, version 2, a copy of which is included in the source distribution. .SH THANKS Many thanks to George Danchev, Thomas Schoepf and Sven Luther for doing the Debian packaging of ara and many helpful comments. .SH CONFIGURATION FILES The system-wide configuration file for m4_ara is \fB/etc/m4_ara.config\fP. Its syntax is self-evident and follows the Ocaml lexical conventions. Values in the user-specific configuration file \fB$HOME/.ara/m4_ara.config\fP override those of \fB/etc/m4_ara.config\fP. m4_ifelse(m4_ara,`ara', `', `The user configuration file can be edited from the \fBConfigure\fP menu item in the \fBSettings\fP menu. GUI parameters such as window sizes and checkbox states are saved at exit in that file.') .SH OTHER FILES m4_ifelse(m4_ara,`ara', `Command line history is saved in \fB$HOME/.ara/ara.history\fP.', `Bookmarks are saved into \fB$HOME/.ara/bookmarks\fP. \fB$HOME/.ara/bookmarks\fP') The following databases are loaded by default: \fB/var/lib/dpkg/available\fP .br \fB/var/lib/dpkg/status\fP .br \fB/var/lib/apt/lists/*_Packages\fP .br \fB/var/lib/apt/lists/*_Sources\fP m4_ifelse(m4_ara,`ara', `.SH ENVIRONMENT VARIABLES In \fBara\fP the variables \fBLINES\fP and \fBCOLUMNS\fP are used to determine the dimensions of the terminal. Note that these variables are not exported by default in your shell ; add \fBexport LINES COLUMNS\fP in your \fB.zshrc\fP or \fB.bashrc\fP.', `') .SH SEE ALSO m4_ifelse(m4_ara,`ara', `\fBxara(1)\fP', `\fBara(1)\fP'), \fBapt-cache\fP(8), \fBaptitude\fP(8), \fBdpkg\fP(8), \fBdselect\fP(8), \fBgrep\-aptavail\fP(1), \fBgrep\-available\fP(1), \fBgrep\-dctrl\fP(1), \fBgrep\-status\fP(1), \fBgrep\-dctrl\fP(1), \fBpackagesearch\fP(1), \fBsynaptic\fP(1). .SH AUTHOR Oguz Berke Durak http://abaababa.ouvaton.org/ara/ m4_ifelse(m4_ara,`ara', `.SH KNOWN BUGS Due to lack of Unicode support, non\-ASCII characters lead to problems under Unicode terminals. Note that the database files are encoded in Latin1.',`') .br ara-1.0.31/gui/0000755000000000000000000000000011553101133010002 5ustar ara-1.0.31/gui/config.ml0000644000000000000000000000015011553072334011607 0ustar (* Config *) (* $Id$ *) module C = Configuration.Make(struct let name = "xara" end)(Opt);; include C;; ara-1.0.31/gui/debug.mli0000644000000000000000000000016511553072334011607 0ustar val sf : ('a, unit, string) format -> 'a val level : int ref val enable : bool ref val debug : int -> string -> unit ara-1.0.31/gui/Makefile0000644000000000000000000000042211553072334011452 0ustar # Makefile BASE = .. EXEC = xara SOURCES = debug.mli debug.ml opt.mli opt.ml config.mli config.ml gui.mli gui.ml LIBS = $(WITHUNIX) $(WITHTHREADS) $(WITHUTIL) \ $(WITHSTR) $(WITHARA) $(WITHCOMMON) \ $(WITHCONFIGFILE) $(WITHGTK2_THREAD) include Makefile.exec ara-1.0.31/gui/opt.mli0000644000000000000000000000032611553072334011322 0ustar val config_file : string ref val user_specified_config_file : bool ref val dump_config : bool ref val low_memory : int ref val fast : bool ref val very_slow : bool ref val specs : (string * Arg.spec * string) list ara-1.0.31/gui/gui.ml0000644000000000000000000023364311553072334011145 0ustar (* Gui *) (* $Id: gui.ml,v 1.25 2004/10/26 09:44:54 berke Exp $ *) (* vim:set fileencoding=utf-8: *) (* TODO: default pane size adjustment * TODO: implement transitive closure-like higher-order operators * TODO: track dependencies in variables ; update' em * TODO: load/save variables * TODO: generic function caching (isn't this what lazy does ? not really -- or is it ?) * TODO: multiple tasks at once ; installing a package shouldn't freeze flare *) open GMain;; open Gdk;; open Debug;; open Util;; module Prefs = struct let show_empty_fields = ref true end ;; (*** Parse arguments... *) let () = Arg.parse Opt.specs (fun f -> Printf.eprintf "Argument %S ignored.\n" f; flush stderr) (Sys.argv.(0) ^ " [options]") ;; (* ***) let ign f x = ignore (f x) (*** Make *) module Make(Dpkg : Dpkg.DB) = struct module Ara = Ara.Make(Dpkg) (*** Utf8... *) let from_utf8 msg = try Glib.Convert.convert msg ~to_codeset:"ISO-8859-1" ~from_codeset:"UTF-8" with | x -> debug 0 (sf "Error trying to convert string %S from UTF-8: %s" msg (Printexc.to_string x)); raise x let to_utf8 msg = try Glib.Convert.convert msg ~to_codeset:"UTF-8" ~from_codeset:"ISO-8859-1" with | x -> debug 0 (sf "Error trying to convert string %S to UTF-8: %s" msg (Printexc.to_string x)); raise x ;; (* ***) (*** Flash... *) let flash_context : GMisc.statusbar_context option ref = ref None let flash_mutex = Mutex.create () let flash msg = match !flash_context with | None -> debug 0 (sf "flash: %s" msg) | Some ctx -> Mutex.lock flash_mutex; ctx#flash ~delay:3000 (to_utf8 msg); Mutex.unlock flash_mutex ;; (* Flash ***) let catch_utf8 x f = try f x with | Glib.Convert.Error(_,_) -> flash "Error: Invalid, non-ISO-8859-1 characters." ;; let db_mutex = Mutex.create ();; let database = new Publication.magazine;; (*** follow_window_size *) let follow_window_size ~window ~name = let esig = new GObj.event_signals window#as_widget in ignore (esig#configure ~callback:(fun cfg -> let (w,h) = (GdkEvent.Configure.width cfg, GdkEvent.Configure.height cfg) in Config.current#set_int ("xara.windows."^name^".width") w; Config.current#set_int ("xara.windows."^name^".height") h; false)) ;; (* ***) (*** database_paths *) let database_paths ?(config = Config.current) () = let k = "xara.database.paths" in let module CF = Configfile in CF.to_list (CF.to_pair CF.to_string CF.to_string) ~k (config#get ?default:(Some(CF.List[CF.Tuple[CF.String "/var/lib/dpkg/"; CF.String "^available$"]])) k) ;; (* ***) (*** compute_interactive_command *) let compute_interactive_command cmd = let runi = Config.current#get_string "xara.commands.run_interactive_command" in Util.substitute_variables ["COMMAND",cmd] runi ;; (* ***) (*** sections_of_database *) let sections_of_database db = let module SS = Set.Make(String) in let j = Dpkg.field_of_string db "section" in let m = Dpkg.get_count db in let rec loop s i = if i = m then s else loop (let u = Dpkg.get_field db i j in if u <> "" then SS.add u s else s) (i + 1) in SS.elements (loop SS.empty 0) ;; (* ***) (*** GDK & GTK2 initialisation... *) let visual = Gdk.Rgb.get_visual ();; let () = Gdk.Rgb.init (); GtkBase.Widget.set_default_visual visual; GtkBase.Widget.set_default_colormap (Gdk.Rgb.get_cmap ()) ;; let hbox p = GPack.hbox ~border_width:5 ~spacing:5 ~packing:p ();; let vbox p = GPack.vbox ~border_width:5 ~spacing:5 ~packing:p ();; let window = GWindow.window ~title:(sf "Xara %s" Version.version) ~allow_grow:true ~allow_shrink:true ~width:(Config.current#get_int ~default:800 "xara.windows.main.width") ~height:(Config.current#get_int ~default:600 "xara.windows.main.height") () ;; (* ***) (*** Busy *) let busy_count = ref 0;; let sleep_cursor = Gdk.Cursor.create `WATCH;; let normal_cursor = Gdk.Cursor.create `LEFT_PTR;; let i_am_busy () = incr busy_count; Gdk.Window.set_cursor window#misc#window sleep_cursor; Gdk.X.flush ();; let i_am_ready () = decr busy_count; if !busy_count = 0 then Gdk.Window.set_cursor window#misc#window normal_cursor; Gdk.X.flush ();; (* Busy ***) (*** Computation *) module Computation = struct exception Busy;; let job = ref None;; let job_mutex = Mutex.create ();; let job_condition = Condition.create ();; let thread () = Mutex.lock job_mutex; while true do begin match !job with | Some(j,job_name) -> flash (sf "Working: %s" job_name); i_am_busy (); begin try j (); job := None; flash (sf "Done: %s" job_name) with | x -> job := None; flash (sf "Job %s failed: %s" job_name (Printexc.to_string x)) end; i_am_ready () | None -> () end; Condition.wait job_condition job_mutex done ;; let launch_job j = if Mutex.try_lock job_mutex then begin let x = match !job with | None -> job := Some j; false | Some _ -> true in Mutex.unlock job_mutex; if x then raise Busy else Condition.signal job_condition end else raise Busy ;; let init () = let ct = Thread.create thread () in () ;; end ;; (* Computation ***) (*** Bookmarks... *) class virtual ['a] bookmarks = object(self) val mutable marks : 'a list = [] val mutable callback : ('a list -> unit) option = None method virtual path : string method virtual load : unit method virtual save : unit method set_callback f = callback <- f method as_list = marks method call_callback f = let marks' = marks in Util.wind f () (fun _ -> if marks <> marks' then match callback with | None -> () | Some f -> f marks else ()) () method clear = self#call_callback (fun () -> List.iter (fun w -> self#remove w) marks) method remove w = self#call_callback (fun () -> marks <- List.filter ((<>) w) marks) method add w = self#call_callback (fun () -> if not (List.mem w marks) then marks <- w::marks else ()) method is_present w = List.mem w marks end ;; class package_marks = object(self) inherit [string * string] bookmarks as super method path = Config.current#path "bookmarks" method load = let fn = self#path in debug 10 (sf "Loading bookmarks from %S" fn); try let ic = open_in fn in self#clear; let sb = Scanf.Scanning.from_file fn in try while true do Scanf.bscanf sb " mark %S %S" (fun pn pv -> self#add (pn,pv)) done; assert false with | x -> close_in ic; flash (to_utf8 (sf "Error reading bookmarks from file %S: %s" fn (Printexc.to_string x))) with | x -> flash (to_utf8 (sf "Could not load bookmarks from file %S: %s" fn (Printexc.to_string x))) method save = let fn = self#path in debug 10 (sf "Saving bookmarks to %S" fn); try Config.current#ensure_directory_presence; let oc = open_out fn in List.iter (fun (pn,pv) -> Printf.fprintf oc "mark %S %S\n" pn pv) marks; close_out oc with | x -> flash (to_utf8 (sf "Could not save bookmarks to file %S: %s" fn (Printexc.to_string x))) end ;; let bookmarks = new package_marks;; (* bookmarks ***) (*** Menu... *) let v0 = GPack.vbox ~spacing:5 ~border_width:5 ~packing:window#add ();; let menu_bar = GMenu.menu_bar ~packing:v0#pack ();; (* ***) (*** package_display *) class package_display ~packing (*~(menu : GMenu.menu GMenu.factory)*) () = let frame = GBin.frame ~packing () in let label = GMisc.label ~use_underline:true ~text:"_Package" () in let _ = frame#set_label_widget (Some(label#coerce)) in let pane = GPack.paned `HORIZONTAL ~packing:frame#add ~border_width:5 () in (* let _ = pane#set_position 400 in *) let vbox_contents = GPack.vbox ~packing:(pane#pack1 ~shrink:false) () in let hbox_contents = GPack.hbox ~packing:vbox_contents#pack () in let package_label = GMisc.label ~text:"No package yet" ~packing:(hbox_contents#pack ~from:`START) () in let show_empty_fields = GButton.check_button ~use_mnemonic:true ~label:"Show empt_y fields" ~active:(Config.current#get_bool ~default:false "xara.windows.main.show_empty_fields") ~packing:(hbox_contents#pack ~from:`END) () in let pf = new Dpkg.paragraph_folder in let sw_contents = GBin.scrolled_window ~packing:vbox_contents#add ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in let contents = GList.clist ~width:200 ~height:100 ~titles:["Field";"Contents"] ~auto_sort:false ~packing:sw_contents#add ~titles_active:false (* ~vadjustment:v_scrollbar#adjustment ~hadjustment:h_scrollbar#adjustment *) (* ~reorderable:true *) () in let _ = label#set_mnemonic_widget (Some(contents#coerce)) in let frame_vbox = GPack.vbox ~packing:(pane#pack2 ~shrink:false) () in let detail_vbox = GPack.vbox ~spacing:15 ~packing:frame_vbox#pack () in let detail_hbox = GPack.hbox ~spacing:15 ~packing:detail_vbox#pack () in let detail_label = GMisc.label ~justify:`CENTER ~text:"No field to display." ~packing:detail_hbox#pack () in let search_hbox = GPack.hbox ~spacing:5 ~packing:detail_vbox#add () in let search_label = GMisc.label ~use_underline:true ~text:"_Search:" ~packing:search_hbox#pack () in let search_entry = GEdit.entry ~packing:search_hbox#add () in let _ = search_label#set_mnemonic_widget (Some(search_entry#coerce)) in let search_bwd_button = GButton.button ~use_mnemonic:true ~stock:`GO_BACK ~packing:search_hbox#pack () and search_fwd_button = GButton.button ~use_mnemonic:true ~stock:`GO_FORWARD ~packing:search_hbox#pack () and search_check_case = GButton.check_button ~use_mnemonic:true ~label:"_Case sensitive" ~active:(Config.current#get_bool ~default:false "xara.windows.main.case_sensitive") ~packing:search_hbox#pack () in let frame_detail = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:frame_vbox#add () in let tags_highlight = GText.tag ~name:"highlight" () in let detail_tag_table = GText.tag_table () in let _ = detail_tag_table#add tags_highlight#as_tag in let _ = tags_highlight#set_property (`BACKGROUND "yellow") in let detail_buffer = GText.buffer ~tag_table:detail_tag_table () in let detail = GText.view ~height:100 ~width:150 ~wrap_mode:`WORD ~packing:frame_detail#add ~editable:false ~cursor_visible:false ~border_width:1 ~buffer:detail_buffer () in object(self) val mutable package = [||] val mutable field_text = "" val mutable detail_field = 0 val mutable current_db = None val mutable search_pattern = "" val mutable search_case = false val mutable search_regexp = Str.regexp "" val mutable search_position = (0,0) val export_dir = ref (Sys.getcwd ()) initializer ignore (search_check_case#connect#clicked (fun _ -> Config.current#set_bool "xara.windows.main.case_insensitive" search_check_case#active)); ignore (contents#connect#select_row ~callback:(fun ~row ~column ~event -> self#with_db (fun db -> detail_field <- Dpkg.field_of_string db (contents#get_row_data row)); self#redisplay_detail)); ignore (contents#event#connect#button_press ~callback:(fun ev -> let button = GdkEvent.Button.button ev in if button = 3 then begin GToolbox.popup_menu ~entries:self#popup_entries ~button ~time:(GdkEvent.Button.time ev); true end else false)); ignore (search_entry#connect#activate ~callback:(fun _ -> self#search ())); ignore (search_fwd_button#connect#clicked ~callback:(fun _ -> self#search ())); ignore (search_bwd_button#connect#clicked ~callback:(fun _ -> self#search ~backwards:true ())); ignore (show_empty_fields#connect#clicked ~callback:(fun _ -> Config.current#set_bool "xara.windows.main.show_empty_fields" show_empty_fields#active; self#repopulate)); search_entry#misc#set_sensitive false; contents#set_column ~auto_resize:true 0; contents#set_column ~auto_resize:true 1; (*** bookmark *) method popup_entries = [`I("Bookmark", (fun () -> self#bookmark)); `I("Unbookmark", (fun () -> self#unbookmark)); `S; `I("APT install", (fun () -> self#install)); `I("APT remove", (fun () -> self#remove)); `S; `I("Print", (fun () -> self#print)); `I("Export (as plain text)", (fun () -> self#export))] method clear_bookmarks = match bookmarks#as_list with | [] -> flash "No bookmarks to clear." | l -> let n = List.length l in let md = GWindow.message_dialog ~message:(if n = 1 then "Shall I clear your bookmark ?" else sf "Shall I clear all your %d bookmarks ?" n) ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no ~title:(sf "Clear bookmarks ?") ~modal:true ~show:true () in let answer = md#run () in md#destroy (); if answer = `YES then bookmarks#clear else () method bookmark = self#with_db (fun db -> let pn = package.(Dpkg.package_field db) and pv = package.(Dpkg.version_field db) in if bookmarks#is_present (pn,pv) then flash (to_utf8 (sf "There is already a bookmark for %S (%S)" pn pv)) else begin bookmarks#add (pn,pv); flash (to_utf8 (sf "Added bookmark for %S (%S)" pn pv)) end) method unbookmark = self#with_db (fun db -> let pn = package.(Dpkg.package_field db) and pv = package.(Dpkg.version_field db) in if bookmarks#is_present (pn,pv) then begin bookmarks#remove (pn,pv); flash (to_utf8 (sf "Removed bookmark for %S (%S)" pn pv)) end else flash (to_utf8 (sf "There is no bookmark for %S (%S)" pn pv))) (* ***) (*** search *) method contents_widget = contents method search ?(backwards=false) () = catch_utf8 () (fun () -> let u = from_utf8 (search_entry#text) in if search_case <> search_check_case#active or u <> search_pattern then begin try search_case <- search_check_case#active; search_regexp <- if search_case then Str.regexp u else Str.regexp_case_fold u; search_pattern <- u; search_position <- (0,0) with | x -> flash (sf "Bad search pattern: %s" (Printexc.to_string x)) end; if u = search_pattern && Array.length package > detail_field then begin try let w = field_text in let (spi,spj) = search_position in if backwards then ignore (Str.search_backward search_regexp w (max 0 (spi - 1))) else ignore (Str.search_forward search_regexp w spj); let i = Str.match_beginning () and j = Str.match_end () in search_position <- (i,j); let b = detail_buffer in b#set_text ""; let m = String.length w in if i > 0 then b#insert ~tags:[] (to_utf8 (String.sub w 0 i)); b#insert ~tags:[tags_highlight] (to_utf8 (String.sub w i ((min (m - 1) j) - i))); if j < m then b#insert ~tags:[] (to_utf8 (String.sub w j (m - j))); ignore (detail#scroll_to_iter (b#get_iter (`OFFSET i))); detail#scroll_to_mark ~use_align:true ~yalign:0.5 (`MARK(b#create_mark (b#get_iter_at_char i))) with | Not_found -> flash "Pattern not found." end else ()) (* ***) (*** with_db, redisplay_detail, repopulate, set_package *) method with_db f = match current_db with | None -> flash "No package selected yet !" | Some db -> f db method redisplay_detail = search_entry#misc#set_sensitive true; search_position <- (0,0); self#with_db (fun db -> let c = let u = package.(detail_field) in try ignore (String.index u '\n'); pf#reset; pf#add_string u; pf#get with | Not_found -> u in field_text <- c; detail_label#set_text (Dpkg.display_string_of_field db detail_field); detail#buffer#set_text (to_utf8 field_text)) method repopulate = contents#freeze (); contents#clear (); self#with_db (fun db -> for i = 0 to Array.length package - 1 do let k = Dpkg.display_string_of_field db i in let v = package.(i) in if show_empty_fields#active or v <> "" then let r = contents#append [to_utf8 k; to_utf8 (first_line v)] in contents#set_row_data r (Dpkg.string_of_field db i) else () done); contents#thaw () method set_package db i = if current_db = None then detail_field <- Dpkg.field_of_string db "description"; current_db <- Some db; let pn = Dpkg.name_of db i and pv = Dpkg.version_of db i in package <- Dpkg.get_package db i; package_label#set_text (to_utf8 (sf "%s version %s" pn pv)); self#repopulate; self#redisplay_detail (* ***) (*** output_package_info *) method output_package_info db package oc = let pf = new Dpkg.paragraph_folder in let first_fields = ["package";"version"] and last_fields = ["description"] in let stuff = List.iter (fun fd -> try let fi = Dpkg.field_of_string db fd in if package.(fi) <> "" then begin pf#reset; pf#add_string package.(fi); Printf.fprintf oc "%s: %s\n" (Dpkg.display_name_of_field db fi) pf#get end with | Not_found -> ()) in stuff first_fields; let excluded_fields = first_fields@last_fields in for fi = 0 to Array.length package - 1 do let fd = Dpkg.string_of_field db fi in if not (List.mem fd excluded_fields) && package.(fi) <> "" then begin Printf.fprintf oc "%s: %s\n" (Dpkg.display_name_of_field db fi) package.(fi) end done; stuff last_fields; (* ***) (*** export *) method export = self#with_db (fun db -> let pn = package.(Dpkg.package_field db) and pv = package.(Dpkg.version_field db) in match GToolbox.select_file ~title:(to_utf8 (sf "Export package info for %s (%s) as text file" pn pv)) ~dir:export_dir ~filename:(sf "%s-%s.txt" pn pv) () with | Some(fn) -> begin try let oc = open_out fn in self#output_package_info db package oc; close_out oc; flash (to_utf8 (sf "Package info for %s (%s) exported to file %s" pn pv fn)) with | x -> flash (to_utf8 (sf "Could not export package info into file %s: %s" fn (Printexc.to_string x))) end | None -> ()) (* ***) (*** print *) method print = self#with_db (fun db -> let pn = package.(Dpkg.package_field db) and pv = package.(Dpkg.version_field db) in try Computation.launch_job ((fun () -> let cmd = Util.substitute_variables ["PACKAGE", pn; "VERSION", pv] (Config.current#get_string "xara.commands.print") in let (ic,oc,ec) = Unix.open_process_full cmd (Unix.environment ()) in self#output_package_info db package oc; let ps = Unix.close_process_full (ic,oc,ec) in GtkThread.async flash (match ps with | Unix.WEXITED(rc) -> if rc = 0 then sf "Printing of information on %S (%S) succeeded" pn pv else sf "Printing of information on %S (%S) failed with code %d" pn pv rc | Unix.WSIGNALED(sg) -> sf "Printing of information on %S (%S) failed with signal %d" pn pv sg | Unix.WSTOPPED(sg) -> sf "Printing of information on %S (%S) stopped by signal %d" pn pv sg)), sf "Printing information on %S (%S)..." pn pv) with | Computation.Busy -> flash "Busy...") (* ***) (*** install, remove, install_or_remove *) method install = self#install_or_remove ~remove:false method remove = self#install_or_remove ~remove:true method install_or_remove ~remove = self#with_db (fun db -> let pn = package.(Dpkg.package_field db) and pv = package.(Dpkg.version_field db) in let cmd = Util.substitute_variables ["PACKAGE",pn; "VERSION",pv] (if remove then Config.current#get_string "xara.commands.remove" else Config.current#get_string "xara.commands.install") in let icmd = compute_interactive_command cmd in let md = GWindow.message_dialog ~message:(to_utf8 (sf "Are you sure you want to %s\n%S version %S ?\n\n\ The following command will be launched:\n\n\ %S" (if remove then "remove" else "install") pn pv icmd)) ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no ~title:(sf "Software %s" (if remove then "removal" else "installation")) ~modal:true ~show:true () in let answer = md#run () in md#destroy (); if answer = `YES then begin try Computation.launch_job ((fun () -> let rc = Sys.command icmd in GtkThread.async flash (if rc <> 0 then (sf "%s of %S (%S) failed with code %d" (if remove then "Removal" else "Installation") pn pv rc) else (sf "%s of %S (%S) succeeded" (if remove then "Removal" else "Installation") pn pv))), (sf "%s %S version %S" (if remove then "Removing" else "Installing") pn pv)) with | Computation.Busy -> flash "Busy..." end) end;; (* ***) (* package_display ***) (*** results_display *) class results_display ~popup_entries ~packing () = let frame = GBin.frame ~packing () in let frame_label = GMisc.label ~use_underline:true ~text:"_Result" () in let _ = frame#set_label_widget (Some(frame_label#coerce)) in let frame_v = GPack.vbox ~packing:frame#add ~border_width:5 () in let h = GPack.hbox ~packing:frame_v#pack ~border_width:5 () in let label = GMisc.label ~text:"No result yet." ~packing:(h#pack ~from:`START) () in let check_coalesce = GButton.check_button ~use_mnemonic:true ~label:"_Newest only" ~active:(Config.current#get_bool ~default:true "xara.windows.main.newest_only") ~packing:(h#pack ~from:`END) () in let frame_h = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:frame_v#add () in let contents = GList.clist ~width:500 ~height:100 ~titles:["Name";"Version";"Description"] ~packing:frame_h#add ~titles_active:false () in let _ = frame_label#set_mnemonic_widget (Some(contents#coerce)) in let ( **> ) x y = if x = 0 then y () else x in let sort db l = let a = Array.of_list l in Array.sort (fun i j -> ((compare (Dpkg.name_of db i) (Dpkg.name_of db j)) **> (fun () -> compare (Dpkg.version_of db j) (Dpkg.version_of db i))) **> (fun () -> compare i j)) a; Array.to_list a in object(self) val mutable package_list = [] val mutable coalesced_package_list = [] val mutable current_db = None val mutable when_selected = fun _ _ -> () initializer ignore (check_coalesce#connect#clicked (fun _ -> Config.current#set_bool "xara.windows.main.newest_only" check_coalesce#active; self#repopulate)) method displayed_package_list = if check_coalesce#active then coalesced_package_list else package_list method set_when_selected f = when_selected <- f method with_db f = match current_db with | None -> () | Some db -> f db initializer ignore (contents#connect#select_row ~callback:(fun ~row ~column ~event -> self#with_db (fun db -> let x = List.nth (self#displayed_package_list) row in when_selected db x; let name = Dpkg.name_of db x in flash (sf "Package %s selected." name)))); ignore (contents#event#connect#button_press ~callback:(fun ev -> let button = GdkEvent.Button.button ev in if button = 3 then begin GToolbox.popup_menu ~entries:popup_entries ~button ~time:(GdkEvent.Button.time ev); true end else false)); List.iter (contents#set_column ~auto_resize:true) [0;1;2] method repopulate = contents#freeze (); i_am_busy (); contents#clear (); contents#set_column ~visibility:(not check_coalesce#active) 1; self#with_db (fun db -> let description_field = Dpkg.field_of_string db "description" in List.iter (fun i -> ignore (contents#append (List.map (fun (f,l) -> to_utf8 (limit l (first_line (Dpkg.get_field db i f)))) [Dpkg.package_field db,32; Dpkg.version_field db,32; description_field,256]))) self#displayed_package_list); contents#thaw (); i_am_ready (); let n = List.length package_list and n' = List.length coalesced_package_list in label#set_text (sf "Total %d package%s (and %d version%s)." n' (if n' = 1 then "" else "s") n (if n = 1 then "" else "s")) method set_package_list db pl = current_db <- Some db; package_list <- sort db pl; coalesced_package_list <- sort db (Ara.filter_old_versions db pl); self#repopulate end ;; (* results_display ***) (*** configure *) class configure config' () = let config = Configurator.duplicate config' in let cd = GWindow.window ~allow_grow:true ~allow_shrink:true ~width:(Config.current#get_int ~default:700 "xara.windows.config.width") ~height:(Config.current#get_int ~default:500 "xara.windows.config.height") ~title:"Configure Flare" ~modal:true ~show:false () in let _ = follow_window_size ~window:cd ~name:"config" in let vb1 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:cd#add () in (* search paths *) let f1 = GBin.frame ~label:"Database search _paths" ~packing:vb1#add () in let nb1 = GPack.notebook ~border_width:5 ~packing:f1#add () in let vb11 = GPack.vbox ~spacing:5 ~packing:(ign (nb1#append_page ~tab_label:((GMisc.label ~text:"Edit" ())#coerce))) () in let vb12 = GPack.vbox ~spacing:5 ~border_width:5 ~packing:(ign (nb1#append_page ~tab_label:((GMisc.label ~text:"Show" ())#coerce))) () in let sw121 = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:vb12#add () in let hb121 = GPack.hbox ~spacing:5 ~packing:vb12#pack () in let files_label = GMisc.label ~text:"Press \"Slurp\" to see files." ~packing:hb121#pack () in let button_slurp = GButton.button ~use_mnemonic:true ~label:"_Slurp" ~packing:(hb121#pack ~from:`END) () in let files = GList.clist ~titles:["Directory";"File"] ~titles_active:false ~packing:sw121#add () in let _ = files#set_column ~auto_resize:true 0; files#set_column ~auto_resize:true 1 in let hb11 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb11#add () in let sw111 = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:hb11#add () in let pth = GList.clist ~titles:["Directory";"Filename regexp"] ~titles_active:false ~packing:sw111#add () in let _ = pth#set_column ~auto_resize:true 0; pth#set_column ~auto_resize:true 1 in let hb112 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb11#pack () in let edit_dir = GEdit.entry ~packing:hb112#add () in let edit_regex = GEdit.entry ~packing:hb112#add () in let button_change = GButton.button ~use_mnemonic:true ~label:"C_hange" ~packing:hb112#add () in let vb111 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:hb11#pack () in let button_new = GButton.button ~use_mnemonic:true ~label:"_Add" ~packing:vb111#pack () in let button_delete = GButton.button ~use_mnemonic:true ~label:"_Remove" ~packing:vb111#pack () in (* commands *) let f2 = GBin.frame ~label:"Commands" ~packing:vb1#pack () in let tbl21 = GPack.table ~border_width:5 ~columns:2 ~packing:f2#add () in let tbl_row = ref 0 in let string_entry text = let lbl = GMisc.label ~text () in let ent = GEdit.entry () in tbl21#attach ~left:0 ~top:!tbl_row (lbl#coerce); tbl21#attach ~expand:`X ~left:1 ~top:!tbl_row (ent#coerce); incr tbl_row; ent in let string_entries = List.map (fun (x,y) -> (string_entry x, y)) [ "Run interactive commands with:" ,"xara.commands.run_interactive_command"; "Install:", "xara.commands.install"; "Remove:" ,"xara.commands.remove"; "Update:" ,"xara.commands.update"; "Upgrade:" ,"xara.commands.upgrade"; "Dist-upgrade:" ,"xara.commands.dist_upgrade"; "Print:" ,"xara.commands.print" ] in (* buttons *) let hb3 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb1#pack () in let button_apply = GButton.button ~use_mnemonic:true ~label:"_Use these" ~packing:hb3#add () in let button_save = GButton.button ~use_mnemonic:true ~label:"_Save" ~packing:hb3#add () in let button_restore = GButton.button ~use_mnemonic:true ~label:"Rest_ore" ~packing:hb3#add () in let button_defaults = GButton.button ~use_mnemonic:true ~label:"_Defaults" ~packing:hb3#add () in let button_cancel = GButton.button ~use_mnemonic:true ~label:"_Cancel" ~packing:hb3#add () in let st1 = GMisc.statusbar ~packing:vb1#pack () in let ctx = st1#new_context ~name:"Message" in object(self) val mutable current_row = None val mutable paths = database_paths ~config () initializer ignore (button_new#connect#clicked (fun _ -> paths <- ("","")::paths; ignore (pth#insert ~row:0 ["";""]); pth#select 0 0)); ignore (pth#connect#select_row ~callback:(fun ~row ~column ~event -> current_row <- Some row; let (x,y) = List.nth paths row in edit_dir#set_text (to_utf8 x); edit_regex#set_text (to_utf8 y))); ignore (button_change#connect#clicked (fun _ -> match current_row with | None -> ctx#flash "Don't know which row to change." | Some i -> catch_utf8 () (fun () -> let x = from_utf8 edit_dir#text and y = from_utf8 edit_regex#text in paths <- Util.list_change_nth paths i (x,y); self#repopulate))); ignore (button_delete#connect#clicked (fun _ -> match current_row with | None -> ctx#flash "Don't know which row to delete." | Some i -> pth#remove ~row:i; current_row <- None; paths <- Util.list_remove_nth paths i)); ignore (button_apply#connect#clicked (fun _ -> self#depopulate; config'#set_context (Configfile.duplicate_context config#context); cd#destroy ())); ignore (button_restore#connect#clicked (fun _ -> config#set_context (Configfile.duplicate_context config'#context); self#repopulate)); ignore (button_defaults#connect#clicked (fun _ -> match config#load_defaults with | [] -> self#repopulate | ex -> ctx#flash (to_utf8 (sf "Errors occured: %s" (String.concat "," (List.map (fun (fn,x) -> sf "%S: %s" fn (Printexc.to_string x)) ex)))) )); ignore (button_save#connect#clicked (fun _ -> self#depopulate; config'#set_context (Configfile.duplicate_context config#context); config'#save)); ignore (button_cancel#connect#clicked (fun _ -> cd#destroy ())); ignore (button_slurp#connect#clicked (fun _ -> self#slurp)); self#repopulate; cd#show () method depopulate = List.iter (fun (x,y) -> config#set_string y (from_utf8 x#text)) string_entries; let module CF = Configfile in config#set "xara.database.paths" (CF.List(List.map (fun (x,y) -> CF.Tuple[CF.String x;CF.String y]) paths)) method slurp = files_label#set_text (to_utf8 (try let fl = Dpkg.find_database_files paths in files#freeze (); files#clear (); List.iter (fun fn -> ignore (files#append [to_utf8 (Filename.dirname fn); to_utf8 (Filename.basename fn)])) fl; files#thaw (); match List.length fl with | 0 -> "Warning: No files match the given patterns." | 1 -> "One database file." | n -> sf "Total %d files." n with | x -> sf "Error: %s" (Printexc.to_string x))) method repopulate = List.iter (fun (x,y) -> x#set_text (to_utf8 (config#get_string y))) string_entries; current_row <- None; pth#freeze (); pth#clear (); List.iter (fun (x,y) -> ignore (pth#append [to_utf8 x; to_utf8 y])) paths; pth#thaw () end ;; (* ***) (*** apt_update *) let apt_update vr () = let update_cmd = compute_interactive_command (Config.current#get_string vr) in let md = GWindow.message_dialog ~message:(to_utf8 (sf "Okay to launch command\nthe following command ?\n\n%s" update_cmd)) ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no ~title:(sf "APT update") ~modal:true ~show:true () in let answer = md#run () in md#destroy (); if answer = `YES then try Computation.launch_job ((fun () -> let rc = Sys.command update_cmd in GtkThread.async flash (if rc <> 0 then (sf "APT update failed with code %d" rc) else "APT update succeeded")), "APT update in progress...") with | Computation.Busy -> flash "Busy..." ;; (* ***) (*** syntax_help *) (* TODO: text search field for syntax help *) class syntax_help ~packing () = let f3 = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing () in let t1 = GText.view ~height:100 ~width:100 ~wrap_mode:`WORD ~packing:f3#add ~editable:false ~cursor_visible:false ~border_width:1 () in object(self) initializer t1#buffer#set_text Help.syntax end ;; class help_window ?(on_close = ignore) () = let hw = GWindow.window ~title:(sf "Xara %s help" Version.version) ~modal:false ~show:false ~allow_grow:true ~allow_shrink:true ~width:(Config.current#get_int ~default:400 "xara.windows.help.width") ~height:(Config.current#get_int ~default:300 "xara.windows.help.height") () in let _ = follow_window_size ~window:hw ~name:"help" in let _ = hw#connect#destroy ~callback:(fun () -> on_close ()) in let v = GPack.vbox ~border_width:5 ~spacing:5 ~packing:hw#add () in let sh = new syntax_help ~packing:v#add () in let h = GPack.hbox ~border_width:5 ~spacing:5 ~packing:v#pack () in let b = GButton.button ~use_mnemonic:true ~label:"_Close" ~packing:(h#pack ~from:`END) () in object(self) initializer ignore (b#connect#clicked (fun _ -> self#close)); hw#show () method close = hw#destroy () method present = hw#present () end ;; (* ***) (*** error_display *) class error_display ~packing () = let tags_parse_head = GText.tag ~name:"parse_head" () in let tags_query = GText.tag ~name:"tags_query" () in let tags_query_highlight = GText.tag ~name:"tags_query_highlight" () in let tags_ast = GText.tag ~name:"tags_ast" () in let errors_tag_table = GText.tag_table () in let errors_buffer = GText.buffer ~tag_table:errors_tag_table () in let errors_frame = GBin.frame ~packing () in let errors_sw = GBin.scrolled_window ~packing:errors_frame#add ~height:80 ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in let errors_view = GText.view ~packing:errors_sw#add ~editable:false ~cursor_visible:false ~border_width:1 ~buffer:errors_buffer ~wrap_mode:`WORD () in let ast_font_size = 7 in object(self) initializer errors_tag_table#add tags_parse_head#as_tag; errors_tag_table#add tags_query_highlight#as_tag; errors_tag_table#add tags_ast#as_tag; tags_parse_head#set_property (`STYLE `ITALIC); tags_query_highlight#set_property (`BACKGROUND "red"); tags_ast#set_property (`FONT (sf "Monospace %d" ast_font_size)); (* tags_ast#set_property (`SIZE 8) *) method show_ast q = let b = errors_view#buffer in b#set_text ""; b#insert ~tags:[tags_parse_head] "Query syntax tree:\n"; let f = Format.make_formatter (fun u i m -> b#insert ~tags:[tags_ast] (to_utf8 (String.sub u i m))) (fun _ -> ()) in let n = (match errors_view#get_window `TEXT with | Some w -> let (n,m) = Gdk.Drawable.get_size w in max 5 (n / (1 + ast_font_size)) | None -> 30) in let n = 3 * n / 4 in Format.pp_set_max_indent f (2 * n / 3); Format.pp_set_margin f n; Ast.dump f q method no_parse_error () = errors_buffer#set_text "" method show_message msg = let b = errors_view#buffer in b#set_text ""; b#insert ~tags:[tags_parse_head] (to_utf8 msg) method show_parse_error i j x w = let b = errors_view#buffer in b#set_text ""; let m = String.length w in if m = 0 then b#insert ~tags:[tags_parse_head] "Empty query." else begin if i = j then if i >= m - 1 then begin b#insert ~tags:[tags_parse_head] (sf "At end of query: %s.\n" x); b#insert ~tags:[] (to_utf8 w); b#insert ~tags:[tags_query_highlight] " " end else begin b#insert ~tags:[tags_parse_head] (sf "At character %d: %s.\n" (i + 1) x); if i > 0 then b#insert ~tags:[] (to_utf8 (String.sub w 0 (min (m - 1) i))); if i < m then b#insert ~tags:[tags_query_highlight] (to_utf8 (String.sub w i 1)); if i + 1 < m then b#insert ~tags:[] (to_utf8 (String.sub w (j + 1) (m - j - 1))) end else begin b#insert ~tags:[tags_parse_head] (to_utf8 (sf "Between characters %d and %d: %s.\n" (i + 1) (j + 1) x)); if i > 0 then b#insert ~tags:[] (to_utf8 (String.sub w 0 (min (m - 1) i))); if i < m then b#insert ~tags:[tags_query_highlight] (to_utf8 (String.sub w i ((min (m - 1) j) - i + 1))); if j + 1 < m then b#insert ~tags:[] (to_utf8 (String.sub w (j + 1) (m - j - 1))) end end end ;; (* ***) (*** query_book *) module SM = Map.Make(String);; class query_book ~packing () = let fr = GBin.frame ~packing () in let vb = GPack.vbox ~packing:fr#add () in let label = GMisc.label ~use_underline:true ~text:"_Variables" () in let _ = fr#set_label_widget (Some(label#coerce)) in let hb = GPack.hbox ~border_width:5 ~packing:vb#add () in let sw = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:hb#add () in let vb = GPack.vbox ~border_width:5 ~packing:hb#pack () in let button_edit = GButton.button ~use_mnemonic:true ~label:"_Edit" ~packing:vb#pack () in let button_delete = GButton.button ~use_mnemonic:true ~label:"_Delete" ~packing:vb#pack () in let button_use = GButton.button ~use_mnemonic:true ~label:"_Use" ~packing:vb#pack () in let queries = GList.clist ~titles:["Variable";"Request";"Population"] ~titles_active:false ~packing:sw#add () in let _ = label#set_mnemonic_widget (Some(queries#coerce)) in object(self) val book : (string * Dpkg.IS.t * Ara.query) SM.t ref = ref SM.empty val mutable current_entry = None val mutable edit_callback : string -> unit = ignore initializer ignore (queries#connect#select_row ~callback:(fun ~row ~column ~event -> current_entry <- Some(queries#get_row_data row))); ignore (button_delete#connect#clicked (fun _ -> match current_entry with | None -> flash "No entry to delete." | Some x -> book := SM.remove x !book; current_entry <- None; self#repopulate)); ignore (button_use#connect#clicked (fun _ -> match current_entry with | None -> flash "No entry to edit." | Some x -> let (w,_,_) = SM.find x !book in edit_callback (to_utf8 w))); ignore (button_edit#connect#clicked (fun _ -> match current_entry with | None -> flash "No entry to use." | Some x -> let (w,_,_) = SM.find x !book in edit_callback (to_utf8 (sf "$%s := %s" x w)))); queries#set_column ~auto_resize:true 0; queries#set_column ~auto_resize:true 1; queries#set_column ~auto_resize:true 2 method repopulate = queries#freeze (); queries#clear (); SM.iter (fun k (w,r,_) -> let r = queries#append [to_utf8 k; to_utf8 w; sf "%d" (Dpkg.IS.cardinal r)] in queries#set_row_data r k) !book; queries#thaw () method book = book method set_edit_callback f = edit_callback <- f end;; (* ***) (*** compute_query *) exception Variable_not_found of string;; let compute_query sm db q w = (* let sm = query_book#book in *) let pl = Ara.compute_query db ~get:(fun id -> try let (_,r,_) = SM.find id !sm in r with | Not_found -> raise (Variable_not_found id)) ~set:(fun id r s1 s2 q -> let w' = try String.sub w s1 (s2 - s1) with | _ -> sf "??? %d,%d" s1 s2 in sm := SM.add id (w',r,q) !sm) q in pl ;; (* ***) (*** requests *) class requests ~results ~query_book ~packing () = let f2_v = GPack.vbox ~border_width:5 ~spacing:5 ~packing () in let query_hbox = GPack.hbox ~packing:f2_v#pack ~spacing:5 () in let query_label = GMisc.label ~use_underline:true ~text:"_Query:" ~packing:query_hbox#pack () in let query_combo = GEdit.combo ~enable_arrow_keys:true ~allow_empty:false ~case_sensitive:true ~popdown_strings:["section:(games or gnome) and (tetris or netris)"] ~packing:query_hbox#add () in let query_edit = query_combo#entry in let _ = query_label#set_mnemonic_widget (Some(query_edit#coerce)) in let button_launch = GButton.button ~use_mnemonic:true ~label:"Run query" ~packing:query_hbox#pack () in let p0 = GPack.paned `VERTICAL ~packing:f2_v#add () in let error_display = new error_display ~packing:p0#add1 () in let database_subscription = database#subscribe () in object(self) initializer query_combo#disable_activate (); ignore (button_launch#connect#clicked ~callback:(fun _ -> self#launch)); ignore (query_edit#connect#activate ~callback:(fun _ -> let l = query_combo#list#all_children in let w = query_edit#text in if not (List.exists (fun li -> List.exists (fun ll -> (GMisc.label_cast ll)#text = w) li#all_children) l) then begin let li = GList.list_item ~label:w () in query_combo#list#insert li 0; end; self#launch)) method set_query w = query_edit#set_text w method launch_parsed q w = try database_subscription#with_last_issue (fun db -> try error_display#show_ast q; Computation.launch_job ((fun () -> let pl = compute_query query_book#book db q w in GtkThread.async (fun () -> query_book#repopulate; results#set_package_list db pl) ()), sf "Process query %s" w) with | Computation.Busy -> flash "Busy !") with | Glib.Convert.Error(e,s) -> error_display#show_message (sf "Illegal, non ISO-8859-1 characters in query. (%s)" s); | Publication.No_issue -> flash "Database unavailable. Try: apt-get update" | x -> flash (sf "Exception: %S" (Printexc.to_string x)) method launch = catch_utf8 () (fun () -> let w = from_utf8 (query_edit#text) in try self#launch_parsed (Ara.statement_of_string w) w with | Ara.Parse_error(i,j,x) -> error_display#show_parse_error i j x w; flash "Parse error." | x -> flash (sf "Error: %s." (Printexc.to_string x))) end ;; (* ***) (*** section_chooser *) let id = ref 0 class section_chooser ~(selection_magazine : string list Publication.magazine) () = let id = incr id; !id in let sd = GWindow.window ~width:200 ~height:500 ~title:"Debian sections" ~modal:false ~show:false () in let vb1 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:sd#add () in (* search paths *) let f1 = GBin.frame ~label:"Available sections" ~packing:vb1#add () in let vb11 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:f1#add () in let hb11 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb11#add () in let sw111 = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:hb11#add () in let sec = GList.clist ~titles:["Section"] ~titles_active:false ~selection_mode:`MULTIPLE ~packing:sw111#add () in (* buttons *) let hb3 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb1#pack () in let button_close = GButton.button ~use_mnemonic:true ~label:"_Close" ~packing:hb3#add () in let db_subscription = database#subscribe () in let sel_subscription = selection_magazine#subscribe () in (* let bundle = new Publication.bundle db_subscription sel_subscription ~callback:ignore in *) object(self) val mutable current_row = None val mutable sections = [] val mutable selection = [] val mutable selection' = [] val mutable dont_publish = false initializer ignore (button_close#connect#clicked (fun _ -> sd#destroy ())); ignore (sd#connect#destroy ~callback:(fun () -> db_subscription#cancel; sel_subscription#cancel)); sel_subscription#set_callback (fun sel -> selection <- sel; GtkThread.async (fun () -> sec#freeze (); self#reselect; sec#thaw ()) ()); db_subscription#set_callback (fun db -> self#recompute_section_list db); ignore (sec#connect#select_row ~callback:(self#new_selection ~select:true)); ignore (sec#connect#unselect_row ~callback:(self#new_selection ~select:false)); db_subscription#tick; sel_subscription#tick; sd#show () method new_selection ~select ~row ~column ~event = if not dont_publish then begin let x = sec#get_row_data row in if select then selection <- x::selection else selection <- List.filter ((<>) x) selection; sel_subscription#publish selection end method private recompute_section_list db = sections <- sections_of_database db; GtkThread.async (fun () -> self#repopulate) () method private reselect = dont_publish <- true; let m = sec#rows in for i = 0 to m - 1 do let x = sec#get_row_data i in if List.mem x selection <> List.mem x selection' then begin if List.mem x selection then sec#select i 0 else sec#unselect i 0 end done; selection' <- selection; dont_publish <- false method private repopulate = sec#freeze (); sec#clear (); List.iter (fun x -> let i = sec#append [to_utf8 x] in sec#set_row_data i x) sections; self#reselect; sec#thaw () end ;; (* ***) (*** simple_requests *) exception Shit;; class simple_requests ~results ~requests ~packing () = let vbox = GPack.vbox ~packing ~border_width:5 ~spacing:10 () in let hbox1 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let name_label = GMisc.label ~text:"Package name contains:" ~packing:hbox1#pack () in let name_entry = GEdit.entry ~packing:hbox1#add () in let hbox2 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let version_label = GMisc.label ~text:"Version is:" ~packing:hbox2#pack () in let (version_combo,_) = GEdit.combo_box_text ~strings:["Don't mind"; "< (strictly less than)"; "<= (less than or equal to)"; "= (equal to)"; "> (greater than)"; ">= (greater than or equal to)"] ~packing:hbox2#add () in let _ = version_combo#set_active 0 in let version_entry = GEdit.entry ~packing:hbox2#add () in let hbox3 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let section_label = GMisc.label ~text:"In sections:" ~packing:hbox3#pack () in let section_entry = GEdit.entry ~packing:hbox3#add () in let section_button = GButton.button ~use_mnemonic:true ~label:"_Choose" ~packing:(hbox3#pack ~from:`END) () in let hbox7 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let install_label = GMisc.label ~text:"Installation status:" ~packing:hbox7#pack () in let (install_combo,_) = GEdit.combo_box_text ~strings:["Don't mind"; "Installed"; "Never installed"; "Deinstalled, still config files"; "Purged"] ~packing:hbox7#add () in let _ = install_combo#set_active 0 in let hbox4 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let description_label = GMisc.label ~text:"Description contains:" ~packing:hbox4#pack () in let vbox41 = GPack.vbox ~packing:hbox4#add ~spacing:5 () in let hbox411 = GPack.hbox ~packing:vbox41#add ~spacing:5 () in let all_of_label = GMisc.label ~text:"All of these words:" ~packing:hbox411#pack () in let all_of_entry = GEdit.entry ~packing:hbox411#add () in let hbox412 = GPack.hbox ~packing:vbox41#add ~spacing:5 () in let some_of_label = GMisc.label ~text:"Some of these words:" ~packing:hbox412#pack () in let some_of_entry = GEdit.entry ~packing:hbox412#add () in let hbox413 = GPack.hbox ~packing:vbox41#add ~spacing:5 () in let none_of_label = GMisc.label ~text:"None of these words:" ~packing:hbox413#pack () in let none_of_entry = GEdit.entry ~packing:hbox413#add () in let hbox5 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let depends_label = GMisc.label ~text:"Depends on:" ~packing:hbox5#pack () in let depends_entry = GEdit.entry ~packing:hbox5#add () in (*let hbox6 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in*) let not_depends_label = GMisc.label ~text:"but not on:" ~packing:hbox5#pack () in let not_depends_entry = GEdit.entry ~packing:hbox5#add () in let hbox8 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in let size_label = GMisc.label ~text:"Size:" ~packing:hbox8#pack () in let (size_combo,_) = GEdit.combo_box_text ~strings:["Don't mind"; "<"; ">"] ~packing:hbox8#add ~width:60 () in let _ = size_combo#set_active 0 in let size_entry = GEdit.entry ~packing:hbox8#add () in let (size_unit_combo,_) = GEdit.combo_box_text ~strings:["B"; "KiB"; "MiB"] ~packing:hbox8#add () in let _ = size_unit_combo#set_active 1 in let hbox9 = GPack.hbox ~packing:(vbox#pack ~from:`END) ~spacing:5 () in let launch_button = GButton.button ~use_mnemonic:true ~label:"Run query" ~packing:(hbox9#pack ~from:`END) () in let sections = new Publication.magazine in let section_subscription = sections#subscribe () in let database_subscription = database#subscribe () in object(self) initializer ignore (launch_button#connect#clicked ~callback:(fun _ -> self#launch)); section_subscription#set_callback (fun x -> Debug.debug 0 "receive"; let y = String.concat " " x in section_entry#set_text (to_utf8 y)); ignore (section_entry#connect#activate ~callback:(fun _ -> Debug.debug 0 "activated"; catch_utf8 () (fun () -> try let w = from_utf8 section_entry#text in let l = Util.parse_strings w in database_subscription#with_last_issue (fun db -> Debug.debug 0 "dbli"; let secs = sections_of_database db in List.iter (fun x -> if not (List.mem x secs) then begin flash (sf "Unknown section %S." x); raise Shit end) l); Debug.debug 0 "publish"; section_subscription#publish l with | Shit -> () | x -> flash (sf "Bad section list: %s." (Printexc.to_string x))))); ignore (section_button#connect#clicked ~callback:(fun _ -> ignore (section_entry#misc#activate ()); let sd = new section_chooser ~selection_magazine:sections () in ())) method launch = try let r = ref None in let put x = match !r with | None -> r := Some x | Some y -> r := Some(Ast.And(x,y)) in let do_field ?(negate=false) ?(disjunct=false) fd w = let negif x = if negate then Ast.Not(x) else x in let contents = try Util.parse_strings w with | Failure(x) -> flash (sf "Field %s: %s." fd x); raise Shit in let options = [Ast.Case_insensitive] in begin match contents with | [] -> () | [x] -> put (negif (Ast.Atom( Ast.Matches(Ast.This_field(fd), Ast.Regular(Util.reg_of_string x, options))))) | x::r -> put (Ast.Meta(Ast.With_field(Ast.This_field(fd)), (List.fold_left (fun x y -> let z = Ast.Atom(Ast.Matches( Ast.Current_field, Ast.Regular(Util.reg_of_string y, options))) in if disjunct then if negate then Ast.And(x,z) else Ast.Or(x,z) else if negate then Ast.Or(x,Ast.Not(z)) else Ast.And(x,z)) (negif (Ast.Atom(Ast.Matches( Ast.Current_field, Ast.Regular(Util.reg_of_string x, options))))) r))) end in catch_utf8 () (fun () -> do_field "package" (from_utf8 (name_entry#text)); do_field "description" (from_utf8 (all_of_entry#text)); do_field "description" ~disjunct:true (from_utf8 (some_of_entry#text)); do_field "description" ~negate:true (from_utf8 (none_of_entry#text)); do_field "depends" (from_utf8 (depends_entry#text)); do_field "depends" ~negate:true (from_utf8 (not_depends_entry#text)); do_field "section" ~disjunct:true (from_utf8 (section_entry#text)); begin let ver = from_utf8 (version_entry#text) in let vercomp = version_combo#active in if ver <> "" && vercomp > 0 then put (Ast.Atom(Ast.Matches(Ast.This_field("version"), (match vercomp with | 1 -> Ast.Lexicographic_lt(ver) | 2 -> Ast.Lexicographic_le(ver) | 3 -> Ast.Exact(ver) | 4 -> Ast.Lexicographic_ge(ver) | _ -> Ast.Lexicographic_gt(ver))))) end; begin let install = install_combo#active in if install <> 0 then put (Ast.Atom(Ast.Matches(Ast.This_field("status"), Ast.Exact(match install with | 1 -> "install ok installed" | 2 -> "" | 3 -> "deinstall ok config-files" | _ -> "purge ok not-installed")))) end; begin let size_decimal = from_utf8 (size_entry#text) in let size_comp = size_combo#active in let size_unit = size_unit_combo#active in if size_decimal <> "" && size_comp > 0 then try let size = float_of_string size_decimal in let size = match size_unit with | 0 -> size | 1 -> size *. 1024.0 | _ -> size *. 1048576.0 in if size < 0.0 then raise Shit; let size = Int64.to_string (Int64.of_float size) in put (Ast.Atom(Ast.Matches(Ast.This_field("size"), (match size_comp with | 1 -> Ast.Lexicographic_lt(size) | _ -> Ast.Lexicographic_gt(size))))) with | _ -> flash "Bad package size."; raise Shit else () end; match !r with | None -> requests#launch_parsed (Ast.Display(Ast.True)) "(simple request)" | Some q -> requests#launch_parsed (Ast.Display(q)) "(simple request)") with | Shit -> () end ;; (* ***) (*** request_frame *) class request_frame ~results ~packing () = (* let pane = GPack.paned `VERTICAL ~packing ~border_width:5 () in *) let notebook1 = GPack.notebook ~packing () in (* Advanced, Simple *) let query_book = new query_book ~packing:(ign (notebook1#append_page ~tab_label:((GMisc.label ~text:"Variables" ())#coerce))) () in let requests = new requests ~results ~query_book ~packing:(ign (notebook1#prepend_page ~tab_label:((GMisc.label ~text:"Advanced" ())#coerce))) () in let syntax_help = new syntax_help ~packing:(ign (notebook1#append_page ~tab_label:((GMisc.label ~text:"Syntax help" ())#coerce))) () in let simple_requests = new simple_requests ~results ~requests ~packing:(ign (notebook1#append_page ~tab_label:((GMisc.label ~text:"Simple" ())#coerce))) () in object(self) initializer query_book#set_edit_callback requests#set_query; method requests = requests end ;; (* ***) (*** load_database, reload_database *) let load_database ?(after = fun _ -> ()) (dbfn:(string * string) list) = try Computation.launch_job ((fun () -> try let dbfns = List.fold_left (fun l (path,patt) -> let fns = Slurp.slurp path in let re = Str.regexp patt in let rec loop curpath (l : string list) = function | Slurp.File(fn,_) -> if try ignore (Str.search_forward re fn 0); true with Not_found -> false then (Filename.concat curpath fn)::l else l | Slurp.Directory(d,fl) -> List.fold_left (fun l t -> loop (Filename.concat curpath d) l t) l fl | Slurp.Error(_,_) -> l in loop "" l fns) [] dbfn in let progress = let last = ref 0.0 in fun fn count -> let t = Unix.gettimeofday () in if t > !last +. 0.5 then begin GtkThread.async flash (sf "Loaded %d packages (processing %S)" count fn); last := t end; in let db' = Dpkg.load ~fast:!Opt.fast ~progress dbfns in database#publish `Everyone db'; after db' with | x -> debug 0 (sf "Could not load database: %s. Try: apt-get update\n" (Printexc.to_string x))), "Load database...") with | Computation.Busy -> flash ("Busy...") ;; (* load_database ***) (*** Layout... *) let p0 = GPack.paned `VERTICAL ~packing:v0#add ();; let p1 = GPack.paned `HORIZONTAL ~packing:(p0#pack2 ~shrink:false) ();; let st1 = GMisc.statusbar ~packing:v0#pack ();; let st1_ctx_exception = st1#new_context ~name:"Exception" ;; let _ = flash_context := Some(st1_ctx_exception);; let package_display = new package_display ~packing:(p0#pack1 ~shrink:true) ();; let results = new results_display ~popup_entries:package_display#popup_entries ~packing:(p1#pack1 ~shrink:true) ();; let request_frame = new request_frame ~results ~packing:(p1#pack2 ~shrink:false) ();; let _ = results#set_when_selected package_display#set_package;; (* ***) (*** bookmark_menu_callback *) let bookmark_menu_callback ~before ~menu l = try let set_package pn pv () = database#with_last_issue (fun db -> try let i = Dpkg.find_package db pn pv in package_display#set_package db i; flash (to_utf8 (sf "Selected %s (%s)" pn pv)) with | Not_found -> flash (to_utf8 (sf "Package %s (%s) not found !" pn pv))) in database#with_last_issue (fun db -> let entries = before @ (List.map (fun (pn, pv) -> let lb = to_utf8 (sf "%s (%s)" pn pv) in `I(lb, set_package pn pv)) l) in List.iter (fun x -> menu#remove x) menu#all_children ; GToolbox.build_menu (menu : GMenu.menu) ~entries) with | Publication.No_issue -> flash "No database loaded." ;; (* ***) (*** main_menu *) module Do = struct let syntax_help = let hw = ref None in fun () -> match !hw with | None -> hw := Some(new help_window ~on_close:(fun _ -> hw := None) ()) | Some(hw') -> hw'#present ;; let quit () = bookmarks#save; Config.current#save; GtkMain.Main.quit () ;; let about () = let md = GWindow.message_dialog ~message:Help.gui_about ~message_type:`INFO ~buttons:GWindow.Buttons.ok ~title:"About Xara" ~modal:true ~show:true () in ignore (md#run ()); md#destroy () ;; let enter_query = let last_query = ref "" in fun () -> match GToolbox.input_string ~title:"Enter query to process" ~ok:"Run query" ~text:(to_utf8 !last_query) "Please enter your request." with | None -> () | Some w -> last_query := w; request_frame#requests#set_query w; request_frame#requests#launch ;; let apt_update = apt_update;; let reload_database () = flash "Reloading database..."; load_database (database_paths ()) ~after:(fun db -> results#set_package_list db []) ;; let configure () = ignore (new configure Config.current ()) ;; let show_memory () = let words = let (miw,prw,maw) = Gc.counters () in (miw +. maw -. prw) /. 1000000.0 in let pgsz = Config.current#get_int ~default:4096 "cli.misc.page_size" in let (rsz,vsz) = Util.proc_get_rsz_vsz () in let md = GWindow.message_dialog ~title:"Memory usage" ~message_type:`INFO ~buttons:GWindow.Buttons.ok ~message:(sf "Memory usage is %d pages virtual, %d pages resident.\n\ With a page size of %d bytes this gives %.1fMiB virtual \ and %.1fMiB resident.\n\ Approximatively %.1f million words have been allocated.\n\ Current backend: %s" rsz vsz pgsz ((float pgsz) *. (float rsz) /. 1048576.0) ((float pgsz) *. (float vsz) /. 1048576.0) words Dpkg.backend) ~modal:true ~show:true () in ignore (md#run ()); md#destroy () ;; let compact_heap () = i_am_busy (); let (rsz1,vsz1) = Util.proc_get_rsz_vsz () in Gc.compact (); let (rsz2,vsz2) = Util.proc_get_rsz_vsz () in flash (sf "Compaction saved %d resident and %d virtual pages." (rsz1 - rsz2) (vsz1 - vsz2)); i_am_ready () ;; let print () = package_display#print;; let export () = package_display#export;; let install () = package_display#install;; let remove () = package_display#remove;; let bookmark () = package_display#bookmark;; let unbookmark () = package_display#unbookmark;; let clear_bookmarks () = package_display#clear_bookmarks;; let bookmarks_hook (before, menu) = bookmarks#set_callback (Some(bookmark_menu_callback ~before ~menu));; end ;; let main_menu_entry = [ `M("_Xara",ignore, [`I("_Print", Do.print); `I("E_xport (as plain text)", Do.export); `S; `I("_Quit", Do.quit) ]); `M("Book_marks", Do.bookmarks_hook, [`I("_Add package", Do.bookmark); `I("_Remove package", Do.unbookmark); `I("_Clear bookmarks", Do.clear_bookmarks); `S]); `M("_Tools", ignore, [`I("Enter _query", Do.enter_query); `M("APT", [`I("_Install", Do.install); `I("_Remove", Do.remove); `S; `I("_Update", Do.apt_update "xara.commands.update"); `I("Re_load database", Do.reload_database); `S; `I("Up_grade", Do.apt_update "xara.commands.upgrade"); `I("_Dist-upgrade", Do.apt_update "xara.commands.dist_upgrade")]); `M("_Misc", [`I("Show _memory usage", Do.show_memory); `I("Compact _heap", Do.compact_heap)])]); `M("Se_ttings", ignore, [`I("_Configure", Do.configure); (*`I("GUI preferences", (fun () -> ()))*)]); `M("_Help", ignore, [`I("_Syntax help", Do.syntax_help); `I("_About", Do.about)]) ] ;; let _ = let create_menu label menubar = let item = GMenu.menu_item ~use_mnemonic:true ~label ~packing:menubar#append () in GMenu.menu ~packing:item#set_submenu () in List.iter (function `M(x,y,z) -> let menu = create_menu x menu_bar in GToolbox.build_menu menu ~entries:z; y (z, menu)) main_menu_entry ;; (* ***) (*** Main... *) let main () = follow_window_size ~window ~name:"main"; Computation.init (); ignore (window#connect#destroy ~callback:(fun _ -> Do.quit ())); window#show (); load_database (database_paths ()) ~after:(fun db -> bookmarks#load); GtkThread.main () ;; (* ***) end (* ***) let _ = (* load config *) List.iter (fun (fn,ex) -> if fn <> !Opt.config_file or (!Opt.user_specified_config_file & fn = !Opt.config_file) or (match ex with Sys_error(_) -> false | _ -> true) then Printf.printf "Error loading config file %S: %s.\n" fn (Printexc.to_string ex)) (Config.load ()); if !Opt.dump_config then begin Configfile.dump ~show_status:true Format.std_formatter (Configfile.get_config Config.current#context); Format.pp_print_flush Format.std_formatter () end else (* Fix for LablGTK2/Qt engine crashes *) let fn = Config.current#get_string "xara.gtkrc" ~default:"/etc/xara-gtkrc-2.0" in if Sys.file_exists fn then GtkMain.Rc.add_default_file fn; (* Run stuff. *) if !Opt.very_slow then let module M = Make(Dpkg.DBFS) in M.main () else let module M = Make(Dpkg.DBRAM) in M.main () ;; ara-1.0.31/gui/debug.ml0000644000000000000000000000060611553072334011436 0ustar (* Debug *) (* $Id: debug.ml,v 1.2 2004/10/24 20:27:24 berke Exp $ *) let sf = Printf.sprintf;; let mutex = Mutex.create ();; let level = ref 0;; let enable = ref false;; let debug l x = if !enable && l >= !level then begin Mutex.lock mutex; Printf.eprintf "debug(%03d,%05d): %s\n%!" l (Thread.id (Thread.self ())) x; Mutex.unlock mutex end else () ;; ara-1.0.31/gui/gui.mli0000644000000000000000000000000011553072334011271 0ustar ara-1.0.31/gui/config.mli0000644000000000000000000000075111553072334011767 0ustar module C : sig val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list end val home : string val directory : string val primary_file : unit -> string val current : Configurator.configurator module Convert : sig val convert : Oldconfig.t -> Configfile.t end val load : unit -> (string * exn) list ara-1.0.31/gui/opt.ml0000644000000000000000000000176211553072334011156 0ustar (* Opt *) (* $Id: opt.ml,v 1.1 2004/10/26 09:44:54 berke Exp $ *) let config_file = ref "xara.config";; let user_specified_config_file = ref false;; let dump_config = ref false;; let low_memory = ref 131072;; (* KiB *) let fast = ref true;; let very_slow = ref (Util.proc_get_free_mem () < !low_memory);; let specs = [ "-config",Arg.String(fun w -> user_specified_config_file := true; config_file := w), " Set user configuration file name (default ~/.ara/xara.config)"; "-dump-config",Arg.Set(dump_config)," Dump configuration file to stdout."; "-fast",Arg.Clear(very_slow), " Run faster but use more memory."; "-slow",Arg.Set(very_slow), " Use minimal amount of memory but run very slowly."; "-cache-strings",Arg.Clear(fast), " With -fast, try to conserve memory somewhat."; "-debug",Arg.Set(Debug.enable), " Enable debugging information"; "-debug-level",Arg.Set_int(Debug.level), " Set debugging level (higher is more verbose, max is 100, default is 10)"; ] ;; ara-1.0.31/debian/0000755000000000000000000000000012256116205010447 5ustar ara-1.0.31/debian/changelog0000644000000000000000000003747312256116205012337 0ustar ara (1.0.31build1) trusty; urgency=medium * Rebuild for ocaml-4.01. -- Matthias Klose Mon, 23 Dec 2013 20:26:46 +0000 ara (1.0.31) unstable; urgency=low * QA upload. * Maintainer field set to QA group. * Uploaders field removed, the package is orphaned. * Standards-Version set to 3.9.3. -- Emanuele Rocca Sun, 20 May 2012 21:17:26 +0000 ara (1.0.30) unstable; urgency=low * Rebuild with ocaml 3.12.0 * Add some use cases to README.Debian * Standards-Version: 3.9.1 (no changes needed) * Split build dependencies one per line * Switch to 3.0 (native) source format -- George Danchev Mon, 18 Apr 2011 19:37:15 +0300 ara (1.0.29) unstable; urgency=low * OCaml str library has been renamed to libcamlstr.a, but it is not needed to be linked so dropped (Closes: #580029) -- George Danchev Fri, 11 Jun 2010 21:00:55 +0300 ara (1.0.28) unstable; urgency=low * Use dh-ocaml 0.9 features * Rebuilt for OCaml 3.11.2 * Upgrade Standards-Version to 3.8.4 (no change) -- Sylvain Le Gall Thu, 11 Feb 2010 23:02:42 +0000 ara (1.0.27) unstable; urgency=low [ George Danchev ] * Added httpd/Makefile providing a clean target via config/Makefile.exec [ Sylvain Le Gall ] * Upgrade standards-version to 3.8.2 (no change) * Remove *-byte package which are complicated to maintain, provide either bytecode or native version depending on arch * Update debian/copyright to http://wiki.debian.org/Proposals/CopyrightFormat -- Sylvain Le Gall Fri, 10 Jul 2009 22:57:48 +0000 ara (1.0.26) unstable; urgency=low [ George Danchev ] * Update standards version to 3.8.0, no changes needed. * xara-gtkrc-2.0 is supplied commented out (serving as an example), since LablGTK2 causes xara to crash with some window managers (rendering engines). * Drop BUGS file, since its data are consolidated. [ Samuel Mimram ] * Rebuild with OCaml 3.11. * Use dh-ocaml. * Update compat to 7. -- Samuel Mimram Wed, 04 Mar 2009 09:58:10 +0100 ara (1.0.25) unstable; urgency=low * rebuild against OCaml 3.10.2 -- Stefano Zacchiroli Wed, 28 May 2008 19:58:22 +0200 ara (1.0.24) unstable; urgency=high * add debian/control.in with the usual indirection to fill the Architecture field with the current list of architectures supported by the native code compiler * add debian/README.Debian-source documenting the above change * make debian/rules fail when binary-arch is invoked on architectures which are missing /usr/bin/ocamlopt. It should never happen and probably will only if in the future we drop some more OCaml native architectures and forget to update this package * bump the urgency for the OCaml 3.10.1 transition -- Stefano Zacchiroli Thu, 06 Mar 2008 17:28:20 +0100 ara (1.0.23) unstable; urgency=medium [ Stefano Zacchiroli ] * add myself as an uploder * bump standards-version, no changes needed * bump urgency for the OCaml 3.10.1 transition * add Homepage field * make Vcs-* fields point to trunk/, to avoid checking out tags * fix GTK spelling in package descriptions -- Sylvain Le Gall Sat, 08 Dec 2007 13:55:34 +0100 ara (1.0.22) unstable; urgency=low [ George Danchev ] * Applied a patch from Eric Cooper to fix a ftbfs for notebook objects in GPack which now return an int (Closes: #453191) [ Sylvain Le Gall ] * Add myself to uploaders -- Sylvain Le Gall Sat, 08 Dec 2007 00:35:16 +0100 ara (1.0.21) unstable; urgency=low * Make -list option default output style (Closes: #446454) -- George Danchev Sun, 14 Oct 2007 09:56:54 +0300 ara (1.0.20) unstable; urgency=low * Add missing build-dependency on camlp4. -- Samuel Mimram Sat, 08 Sep 2007 17:58:19 +0200 ara (1.0.19) unstable; urgency=low * Rebuild with OCaml 3.10. -- Samuel Mimram Sat, 08 Sep 2007 17:25:45 +0200 ara (1.0.18) unstable; urgency=low * control: Added armel and kfreebsd-amd64 (Closes: #438338) * control: Do not disable errors in the clean target * menu: Comply with the new section structure -- George Danchev Thu, 16 Aug 2007 21:33:38 +0300 ara (1.0.17) unstable; urgency=low * cli: don't use heap compaction in non-interactive mode * renamed Vcs-Svn to match the final name -- George Danchev Fri, 13 Oct 2006 15:44:19 +0300 ara (1.0.16) unstable; urgency=low * unify heap_compation in cli; use it on initial database load * print update hints if database could not be loaded * minor manpage cleanups * control: XS-X-VCS-Svn: svn://svn.debian.org/svn/ara * debhelper compat level 5 - no changes needed * xara-gtk-byte depends on liblablgtk2-ocaml (Closes: #390686) -- George Danchev Fri, 18 Aug 2006 19:29:12 +0300 ara (1.0.15) unstable; urgency=low * change pointer type from X_CURSOR to LEFT_PTR (Closes: #382824) * add Sources list files to the default {x}ara.config (Closes: #382820) * mention Sources list files in OTHER FILES section of the manpage * mention packagesearch(1) instead of dpkg-iasearch in SEE ALSO section -- George Danchev Mon, 14 Aug 2006 14:26:38 +0300 ara (1.0.14) unstable; urgency=low [ George Danchev ] * trigger database reloading and heap compaction on #update -- George Danchev Sat, 22 Jul 2006 18:15:56 +0300 ara (1.0.13) unstable; urgency=low [ George Danchev ] * improve package description. (Closes: #357831) * README.Debian mantions that this is a native debian source package * remove rules.hack * remove hppa and add hurd-i386 to native arch list [ Samuel Mimram ] * Updated standards version to 3.7.2, no changes needed. * We don't need to remove rpaths anymore. -- Samuel Mimram Fri, 19 May 2006 07:59:54 +0000 ara (1.0.12) unstable; urgency=low * Rebuild with OCaml 3.09.1. * Removing rpath from xara-gtk. -- Samuel Mimram Sun, 29 Jan 2006 11:20:42 +0000 ara (1.0.11) unstable; urgency=low [ George Danchev ] * Add kfreebsd-i386 to supported arch list. (Closes: #327753) * Add copyright information. [ Samuel Mimram ] * Rebuild with OCaml 3.09.0, no longer hardcoding OCaml's ABI in control. -- Samuel Mimram Sun, 20 Nov 2005 12:38:55 +0100 ara (1.0.10) unstable; urgency=low [ George Danchev ] * Move generic info from control to README.Debian. (Closes: #317531) * Make clear native/bytecode, resp. faster/slower. (Closes: #325469) * Do *not* mention dpkg-iasearch and magpie in manpage since they're left in oldstable (woody) only and unmaintained. (Closes: #316430) [ Samuel Mimram ] * Updated Standards-Version to 3.6.2. * Updated the FSF address in the copyright file. -- Samuel Mimram Thu, 8 Sep 2005 21:46:06 +0200 ara (1.0.9) unstable; urgency=medium Changes by Samuel Mimram: * Build arch-dependent packages only on archs supported by ocamlopt, closes: #290338. * Updated to OCaml 3.08.3. * Updated Standards-Version to 3.6.1.1. Changes by George Danchev: * README.Debian and copyright reflect the new project's home. -- Samuel Mimram Wed, 23 Mar 2005 12:42:58 +0100 ara (1.0.8) unstable; urgency=low Changes by Samuel Mimram: * Cleaner rules files (binary-arch / indep are really used). (Closes: #286597) * The installation is now made by the main Makefiles instead of the rules. * Added a menu file for xara-gtk. Changes by George Danchev: * Add missing dependency of liblablgtk2-ocaml to xara-gtk and xara-gtk-byte. (Closes: #286367) * dh_strip -a Changed by Berke Durak: * Manual page refers to the Debian package names when talking of ara in xara or of xara in ara. (Closes: #286413) * Backported some speed improvements from 1.1.0 ; -cache-strings turned off by default. * Fixed typos in manual page code examples. (Closes: #286412) * Backported some syntax from 1.1.0 : and operator can be omitted. * Workaround for Qt rendering engine crashes (due to LablGTK or the engine) by means of an extra config. file. (Closes: #286589) -- Oguz Berke Durak Tue, 21 Dec 2004 22:07:08 +0100 ara (1.0.7) unstable; urgency=low * uploaded without proper entries ? -- George Danchev Mon, 20 Dec 2004 00:36:52 +0200 ara (1.0.6) unstable; urgency=low * Fixed important bug in set modules. * Started HTTP daemon. -- Oguz Berke Durak Fri, 3 Dec 2004 17:41:46 +0100 ara (1.0.5b) unstable; urgency=low * Ooops: gui.commands.* -> xara.commands.* * Make clean removes .depend files -- Oguz Berke Durak Wed, 1 Dec 2004 19:20:15 +0100 ara (1.0.5a) unstable; urgency=low * Ooops: cli.commands.pager -> ara.commands.pager -- Oguz Berke Durak Thu, 18 Nov 2004 08:25:06 +0100 ara (1.0.5) unstable; urgency=low * Pane and window size adjustments. -- Oguz Berke Durak Wed, 17 Nov 2004 21:40:37 +0100 ara (1.0.5rc4) unstable; urgency=low Changes by Berke Durak: * Fixed lot of small bugs. * Added #print in CLI. * Automatic selection of low-memory or high-memory backend. * Added apt-get upgrade, apt-get dist-upgrade. * Changed configuration strings to avoit repeating sudo or xterm -e. * Reverted to using Makefiles. -- Oguz Berke Durak Wed, 17 Nov 2004 16:09:49 +0100 ara (1.0.5rc3) unstable; urgency=low Changes by Berke Durak: * Optimized memory usage in normal mode. * Started low memory mode (-very-slow). * Heavily refactored Dpkg module. * Powerful, new configuration file syntax. * Persistance of GUI settings (window size, checkboxes, ...) * Added "Show files" tab to preference editor * Removed Makefiles and converted to ocamlconf. * Replaced ocaml-findlib with ocamlconf in Build-Depends. * Added Home, End, Page Up and Page Down bindings to ledit. Changes by George Danchev: * Added ocaml-findlib in Build-Depends: -- Oguz Berke Durak Mon, 15 Nov 2004 19:41:54 +0100 ara (1.0.4) unstable; urgency=low Changes by George Danchev: * control, control.smart: Added m4 in Build-Depends: * finally complete the implementation of spamoracle magic: native build on arches having ocamlopt and bytecode for all added compat 4, removed -a from dh_installdirs remove control.smart and rules.smart * Add commented DH_COMPAT=4 to rules although using 4 in debian/compat * fix directories for ara-byte, xara-gtk-byte Changes by Berke Durak: * Hopefully got Debver module right this time (ran it against the test suite found in APT) * Added check box for case-insensitive searches in field contents * Added check box to show only newest version * Added a "Simple search" dialog for the syntactically challenged. It contains a button to show the list of existing sections. * Text entry box for searching field contents starts deactivated. * Added a check box to show all fields, even empty ones. -- George Danchev Sat, 6 Nov 2004 21:08:12 +0100 ara (1.0.3) unstable; urgency=low Changes by Berke Durak: * Added Debver module for correctly comparing Debian version numbers. * Uses Debver to filter old versions when -coalesce is set. * Redid menu layout. * Cleaned-up GUI code. * Added menu accelerators and mnemonics. * Added a "Newest only" check box. * Rewritten ara.1 manual page and included ledit manual page. * Changed makefiles to use bytecode compiler by default and to strip executables. * Added version.ml. * Automatic config file creation. * Config files are now in ~/.ara * CLI: added #memory and #compact, #install, #remove. * Fixed zombies and SIGPIPE problem with pager. * Added #fields (equivalent to #set -fields) ; now warns about non-existent fields. Changes by George Danchev: * Add control.smart: trying to port the idea of spamoracle packaging approach - xara-gtk: remove ocaml-base-3.08 from Depends: - xara-gtk-byte: change ocaml-base-3.08 to ocaml-base-nox-3.08 in Depends: - remove ocaml-nox-3.08, ocaml-interp from Build-Depends: * Add rules.smart: - handle installs for ara, ara-byte, xara-gtk, xara-gtk-byte -- Berke Durak Sun, 31 Oct 2004 19:10:30 +0100 ara (1.0.2) unstable; urgency=low * Can change options in interactive mode * Added field merging * Added /var/lib/dpkg/status to default list of databases. This allows to search packages by installation status. * Added redirection operators. * Fixed line breaking. * Added -coalesce option to avoid displaying different versions of a same package. (Still buggy -- does not use the newest version). * Fixed bug : ara now loads config on startup * Better command parsing (less bugs, ignore leading spaces, etc.) -- Berke Durak Thu, 28 Oct 2004 21:41:31 +0200 ara (1.0.1) unstable; urgency=low * Added manpage for xara * Added copyright files for ara and xara * Added README.Debian files for ara and xara * Added changelog files for ara and xara * Added ocaml-base-3.08 as runtime dependency for ara and xara, although they might be natively compiled. Improvements might be ported from the spamoracle package * Use dh_md5sums * Use ocaml-best-compilers instead of ocaml-native-compilers * Use 'make bt' (bytecode) on all arches and 'make' on arches having /usr/bin/ocamlopt * Removed liblablgl-ocaml-dev from Build-Depends -- George Danchev Wed, 27 Oct 2004 15:29:47 +0300 ara (1.0-1) unstable; urgency=low * Initial Release. -- George Danchev Wed, 27 Oct 2004 11:06:15 +0300 ara (0.4.20030813-2) unstable; urgency=low * Acknowledge NUM (Closes: #214993) * Change build dependencies (Closes: #262947: ara: has to be recompiled for ocaml 3.08) -- Thomas Schoepf Tue, 3 Aug 2004 11:37:01 +0200 ara (0.4.20030813-1.3) unstable; urgency=low * NMU to fix previous NMUs. * Updated OcamlMakefile with the version from ocaml-tools. -- Sven Luther Thu, 16 Oct 2003 18:15:11 +0200 ara (0.4.20030813-1.2) unstable; urgency=high * NMU to fix previous NMU. * Ara uses OcamlMakefile, which is somewhat broken, and insist on using the native code compilers, even if they are not installed. Added a build depend on this which should fix the problem, but ideally any hint of OcamlMakefile should be purged from this package, or OcamlMakefile should be fixed. (Closes: #214993) -- Sven Luther Thu, 16 Oct 2003 09:00:49 +0200 ara (0.4.20030813-1.1) unstable; urgency=low * NMU with maintainer's consent. * Modified to conform to the ocaml packaging policy. -- Sven Luther Sun, 5 Oct 2003 12:23:58 +0200 ara (0.4.20030813-1) unstable; urgency=low * New upstream version. -- Thomas Schoepf Fri, 15 Aug 2003 22:39:13 +0200 ara (0.4.20030610-1) unstable; urgency=low * New upstream version. -- Thomas Schoepf Tue, 24 Jun 2003 16:09:52 +0200 ara (0.3.20030501-1) unstable; urgency=low * New upstream version. * -table option no longer displays borders. The new option "-borders" brings them back. Closes: #190088: ara: -table has no borders option -- Thomas Schoepf Thu, 1 May 2003 16:48:11 +0200 ara (0.2.20030318-2) unstable; urgency=low * Closes: #189536: ara: spelling error in package description -- Thomas Schoepf Sat, 19 Apr 2003 12:26:18 +0200 ara (0.2.20030318-1) unstable; urgency=low * Initial Release. -- Thomas Schoepf Thu, 3 Apr 2003 17:47:39 +0200 ara-1.0.31/debian/rules0000755000000000000000000000340311553072333011531 0ustar #!/usr/bin/make -f # -*- makefile -*- # debian/rules for ara package. # # This file was originally written by Joey Hess and Craig Small. # As a special exception, when this file is copied by dh-make into a # dh-make output file, you may use that output file without restriction. # This special exception was added by Craig Small in version 0.37 of dh-make. # # Modified to make a template file for a multi-binary package with separated # build-arch and build-indep targets by Bill Allombert 2001 include /usr/share/ocaml/ocamlvars.mk TMPDIR = $(CURDIR)/debian/tmp ifeq ($(OCAML_HAVE_OCAMLOPT),yes) OCAML_INTERPRETER= else OCAML_INTERPRETER=ocaml-base-nox-$(OCAML_ABI) endif build: build-stamp build-stamp: ifeq ($(OCAML_HAVE_OCAMLOPT),yes) if [ -x /usr/bin/ocamlopt.opt ]; then \ $(MAKE) OPT=.opt ; \ else \ $(MAKE) ; \ fi else if [ -x /usr/bin/ocamlc.opt ]; then \ $(MAKE) OPT=.opt bt ; \ else \ $(MAKE) bt ; \ fi endif $(MAKE) doc touch build-stamp clean: dh_testdir dh_testroot $(MAKE) clean -$(RM) -r $(TMPDIR) -$(RM) build-stamp dh_clean install: build-stamp dh_testdir dh_testroot dh_prep dh_installdirs mkdir -p $(TMPDIR) ifeq ($(OCAML_HAVE_OCAMLOPT),yes) $(MAKE) install DESTDIR=$(TMPDIR) else $(MAKE) install_bt DESTDIR=$(TMPDIR) endif binary-indep: binary-arch: build install dh_testdir -a dh_testroot -a dh_installchangelogs -a dh_install --list-missing -a dh_installdocs -a dh_installexamples -a dh_installmenu -a dh_installman -a dh_installinfo -a dh_link -a dh_compress -a dh_fixperms -a dh_strip -a dh_makeshlibs -a dh_installdeb -a dh_shlibdeps -a dh_ocaml -a dh_gencontrol -a dh_md5sums -a dh_builddeb -a binary: binary-arch binary-indep .PHONY: build clean binary-indep binary-arch binary install ara-1.0.31/debian/ara.install0000644000000000000000000000006711553072333012607 0ustar etc/ara.config usr/bin/ara usr/share/man/man1/ara.1.gz ara-1.0.31/debian/README.Debian0000644000000000000000000000460511553072333012517 0ustar The ara package --------------- This package is Debian specific since it needs Debian package management system to operate. Therefore it is a native debian source package. The package database -------------------- The package database lives, by default, as text files in /var/lib/dpkg/available /var/lib/apt/lists/*_Packages /var/lib/apt/lists/*_Sources /var/lib/dpkg/status It can list everything, installed or not, that are known to the files mentioned above. Note, that there are some fields used in _Release file, but these are not processed yet. If you have packages installed from multiple Debian suites (stable, testing, unstable) and/or from any unofficial repositories ara will see them too, since they would leave traces in the above mentioned files. In short, it is your own system what you perform queries on, so what you get as query results depends on what you have already put into it. Some simple, but interesting examples ------------------------------------- * How many fields are currently known by your Debian Package management System (hold your breath): ara -fields '*' -table 'source://' | head -2 | tail -1 | \ perl -ne 'for (split/\s|\s/) {print("$_\n") if (/^\w/)}' As you already know the fields (columns) known by the database, you can use them to perform complex queries. * Native packages we have: ara -fields Package,Version -table '!version:/\-/' * NMUed packages, i.e. having X.Y as debian revision ara -fields Package,Version -table 'version:/\-[0-9]\.[0-9]$/' * How many packages are Dm-Upload-Allowed: ara -fields Package,Maintainer -table 'Dm-Upload-Allowed:/yes/i' * Dm-Upload-Allowed and being NMUed: ara -fields Package,Version -table 'version:/\-[0-9]\.[0-9]$/ and Dm-Upload-Allowed:/yes/i' * Packages based on $VCS snapshots: ara -fields Package,Version -table 'version:(cvs|svn|git|hg|mtn)' * Projects hosted at *.debian.org ara -fields Package,Version,Homepage -table 'homepage:/debian.org/' * Fun with versions ;-) ara -fields Package,Version -table 'version:/^[3-9][0-9][0-9][0-9][0-9][0-9]/ or version:/unoff/' * required+important_binary ara -fields Package:18,Version:14,Priority:9,Filename -table 'priority:(required|important)' * main_binary ara -fields Package:18,Version:14,Priority:9,Filename -table 'Filename:/^pool\/main/' \ See also -------- http://udd.debian.org -- George Danchev , Sun, 3 Apr 2011 10:17:23 +0300 ara-1.0.31/debian/xara-gtk.install0000644000000000000000000000011511553072333013554 0ustar etc/xara.config etc/xara-gtkrc-2.0 usr/bin/xara usr/share/man/man1/xara.1.gz ara-1.0.31/debian/control0000644000000000000000000000335211756257660012074 0ustar Source: ara Section: utils Priority: optional Maintainer: Debian QA Group Build-Depends: debhelper (>= 7), m4, dh-ocaml (>= 0.9.1), ocaml-nox (>= 3.12.0), ocaml-best-compilers, camlp4 (>= 3.12), liblablgtk2-ocaml-dev (>= 2.12) Standards-Version: 3.9.3 Vcs-Svn: svn://svn.debian.org/svn/ara/trunk Vcs-Browser: http://svn.debian.org/wsvn/ara/trunk Homepage: http://ara.alioth.debian.org/ Package: ara Architecture: any Depends: ${shlibs:Depends}, ${ocaml:Depends}, ${misc:Depends} Provides: ara-byte Conflicts: ara-byte Replaces: ara-byte Recommends: sudo, apt Suggests: a2ps Description: Command line utility for searching the Debian package database ara is a utility for searching the Debian package database using boolean regexp queries. . ara can perform sophisticated searches on that database. It is possible to use any field of the package database as a search criterion and any boolean combination thereof. . ara can also call APT (or any user-configurable command) to install or remove packages matching a query. Package: xara-gtk Architecture: any Depends: ${shlibs:Depends}, ${ocaml:Depends}, ${misc:Depends} Provides: xara-gtk-byte Conflicts: xara-gtk-byte Replaces: xara-gtk-byte Recommends: sudo, apt Suggests: a2ps Description: GTK+ utility for searching the Debian package database ara is a utility for searching the Debian package database using boolean regexp queries. . ara can perform sophisticated searches on that database. It is possible to use any field of the package database as a search criterion and any boolean combination thereof. . ara can also call APT (or any user-configurable command) to install or remove packages matching a query. ara-1.0.31/debian/copyright0000644000000000000000000000240111553072333012401 0ustar Format-Specification: http://wiki.debian.org/Proposals/CopyrightFormat Packaged-By: George Danchev Packaged-Date: Wed, 8 Sep 2004 11:06:15 +0300 Upstream Author: Berke Durak Samuel Mimram George Danchev Original-Source-Location: http://abaababa.ouvaton.org/ara (first location) Files: * Copyright: (C) 2004, 2005 Berke Durak License: GPL-2+ See /usr/share/common-licenses/GPL for details. This is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License with your Debian GNU/Linux system, in /usr/share/common-licenses/GPL, or with the ara source package as the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ara-1.0.31/debian/source/0000755000000000000000000000000011553101133011740 5ustar ara-1.0.31/debian/source/format0000644000000000000000000000001511553100677013163 0ustar 3.0 (native) ara-1.0.31/debian/compat0000644000000000000000000000000211553072333011647 0ustar 7 ara-1.0.31/debian/xara-gtk.menu0000644000000000000000000000024011553072333013051 0ustar ?package(xara-gtk): \ needs="X11" \ section="Applications/System/Package Management" \ title="xara-gtk" \ command="/usr/bin/xara" \ hints="Searching" ara-1.0.31/TODO0000644000000000000000000000341311553072340007716 0ustar ------------------------------------------------------------------------------------- DONE * no .ara/ara.config : complains about non-existence OK * -noconfig: complains about non-existence of ~/.ara/ara.config OK * In DBRAM mode : only first line of description is shown OK * Ledit: HOME ^[[1~ ^[[4~ OK * >> does not work if the file doesn't already exist OK * #set columns -40 does not complain * Remove -coalesce, -nocoalesce OK * #upgrade, #dist-upgrade OK * remove bourbaki thing OK * again: Error: Bad file descriptor ("close_process_out", "") OK * In interactive mode : query is not honored with #set -table, #set -list,etc. OK * show stopper: OK (hopefully) * Fix word wrapping in GUI and printing OK * Fix configuration window size DONE * Rename very-slow DONE * xara complains of missing config file DONE * Auto-select DBFS on low mem DONE * #examples: don't word-wrap OK * print: word-wrap OK * cli: #print OK * Dependencies on libraries : still sucks. OK * DOC: Remove -coalesce, -nocoalesce OK * reload after update DONE Berke, 20050110 * Make table -noborders default output format Berke, 20041030 * Fixed config file creation. (config files renamed to ~/.ara/{,x}ara.config) Berke, 20041028: * BUG: An uncaught exception occurred: Unix.Unix_error(3, "close_process_out", "") => check Ledit. FIXED 20041030 * Include Ledit keyboard commands (ctrl-p etc.) in manual page of ara (not xara) * Unify ara.1 and xara.1 ------------------------------------------------------------------------------------- TODO * In callback for signal destroy, uncaught exception: Sys_error("/home/berke/.ara//home/berke/.ara/xara.config: No such file or directory") * $Id$ * #reset or #defaults * Try to use ocaml-gettext in ara just to have i18n (as suggested by Sylvain Le Gall) ara-1.0.31/config/0000755000000000000000000000000011553101133010463 5ustar ara-1.0.31/config/Makefile.config0000644000000000000000000000430711553072337013410 0ustar # Makefile.config # DEBUG BASE PP CAMLC = ocamlc$(OPT) $(PP) -dtypes -thread $(DEBUG) $(INCDIRS) CAMLOPT = ocamlopt$(OPT) $(PP) $(PROFILE) -dtypes -thread -inline 99 $(INCDIRS) CAMLDEP = ocamldep$(OPT) $(PP) CAMLLEX = ocamllex CAMLYACC = ocamlyacc CUSTOM = -custom INCDIRS = -I $(BASE)/util \ -I $(BASE)/libara \ -I $(BASE)/ledit \ -I $(BASE)/common \ -I $(BASE)/configfile \ -I +lablgtk2 # Custom libraries WITHLEDIT = ledit.cma WITHUTIL = util.cma WITHARA = ara.cma WITHCOMMON = common.cma WITHCONFIGFILE = configfile.cma # Default setting of the WITH* variables. Should be changed if your # local libraries are not found by the compiler. WITHGRAPHICS = graphics.cma -cclib -lgraphics -cclib -L/usr/X11R6/lib -cclib -lX11 WITHUNIX = unix.cma -cclib -lunix WITHSTR = str.cma WITHNUMS = -Idct nums.cma -Ldct -cclib -lnums WITHTHREADS = threads.cma -cclib -lthreads WITHDBM = dbm.cma -cclib -lmldbm -cclib -lndbm WITHBIGARRAY = bigarray.cma WITHGTK2_THREAD = -w s lablgtk.cma gtkInit.cmo gtkThread.cmo WITHPCRE = -I +pcre -cclib -lpcre pcre.cma ############################################################## ################ This part should be generic ################ Nothing to set up or fix here ############################################################## #ocamlc -custom other options graphics.cma other files -cclib -lgraphics -cclib -lX11 #ocamlc -thread -custom other options threads.cma other files -cclib -lthreads #ocamlc -custom other options str.cma other files #ocamlc -custom other options nums.cma other files -cclib -lnums #ocamlc -custom other options unix.cma other files -cclib -lunix #ocamlc -custom other options dbm.cma other files -cclib -lmldbm -cclib -lndbm SOURCES1 = $(SOURCES:.mly=.ml) SOURCES2 = $(SOURCES1:.mll=.ml) SOURCES3 = $(filter %.ml, $(SOURCES2)) OBJS = $(SOURCES3:.ml=.cmo) OPTOBJS = $(SOURCES3:.ml=.cmx) OPTLIBS1 = $(LIBS:.cma=.cmxa) OPTLIBS = $(OPTLIBS1:.cmo=.cmx) .SUFFIXES: .SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly %.cmi : %.mli $(CAMLC) -c $< %.cmx : %.ml %.cmi $(CAMLOPT) -c $< %.cmo : %.ml %.cmi $(CAMLC) -c $*.ml %.ml : %.mll $(CAMLLEX) $< %.ml %.mli : %.mly $(CAMLYACC) $< depend: $(SOURCES2) $(CAMLDEP) *.mli *.ml >.depend .PRECIOUS: %.cmi %.mli %.ml ara-1.0.31/config/Makefile.library0000644000000000000000000000102611553072337013602 0ustar # $Id: Makefile.ara,v 1.1 2004/10/26 09:44:54 berke Exp $ .PHONY: all bt library library.bt all: library bt: library.bt include Makefile.config TARGET = $(LIB).cma library.bt: $(TARGET) library: $(TARGET:.cma=.cmxa) $(TARGET): $(OBJS) $(CAMLC) -a $(OBJS) -o $(TARGET) $(TARGET:.cma=.cmxa): $(OPTOBJS) $(CAMLOPT) -a $(OPTOBJS) -o $(TARGET:.cma=.cmxa) clean: @rm -f *.cm[aiox] *.cmxa *~ .*~ *.[ao] \#*\# *.core *.annot @rm -f $(EXEC) @rm -f $(EXEC).bt @rm -f ara.1 @rm -f $(EXTRA_CLEAN) @rm -f .depend -include .depend ara-1.0.31/config/Makefile.exec0000644000000000000000000000061311553072337013063 0ustar # Makefile.exec .PHONY: all bt TARGET = $(EXEC) all: $(TARGET) bt: $(TARGET).bt include Makefile.config $(TARGET).bt: $(OBJS) $(CAMLC) $(LIBS) $(OBJS) -o $(TARGET).bt $(TARGET): $(OPTOBJS) $(CAMLOPT) $(OPTLIBS) $(OPTOBJS) -o $(TARGET) clean: @rm -f *.cm[aiox] *.cmxa *~ .*~ *.[ao] \#*\# *.core *.annot @rm -f $(EXEC) @rm -f $(EXEC).bt @rm -f ara.1 @rm -f .depend -include .depend ara-1.0.31/INSTALL0000644000000000000000000000274011553072340010261 0ustar WHAT IS IT ? ara (command-line) and xara (GTK2) are utilities for doing boolean regexp queries on the Debian package database. Debian is a distribution of the Linux operating system. DOWNLOAD ara is mostly useful only to Debian users. Source code is available from http://abaababa.ouvaton.org/ara/ INSTALLATION Although a generic use as a formatted plain text database query engine can't be excluded, ara is mostly useful for searching the Debian package database, hence under a Debian system. If you are using Debian, you should install ara by installing its .deb package as any other piece of debianized software. ara is the command-line version and xara is the LablGTK2 version. To compile ara from its sources you need Objective Caml version 3.08.1 or higher. Just untar, then type make ara (or make ara.bt if native-code compilation is not available). See http://caml.inria.fr/ for more info on that great language. Copy the resulting ara.opt or ara in /usr/local/bin. To compile xara you need LablGTK2 installed. Type make xara or make xara.bt for bytecode. Copy the resulting xara/xara or xara/xara.bt in /usr/local/bin. LICENSE ara and xara are, of course, released under the GNU General Public License, version 2, a copy of which is included in the source distribution. THANKS Many thanks to Thomas Schoepf, Sven Luther and George Danchev for their help with Debian packaging. AUTHOR Berke Durak $Id: INSTALL,v 1.1 2003/03/18 14:57:20 berke Exp $ ara-1.0.31/ledit/0000755000000000000000000000000011553101133010317 5ustar ara-1.0.31/ledit/Makefile0000644000000000000000000000023211553072337011771 0ustar # $Id: Makefile.ara,v 1.1 2004/10/26 09:44:54 berke Exp $ BASE = .. LIB = ledit LIBS =$(WITHUNIX) SOURCES = cursor.ml ledit.ml include Makefile.library ara-1.0.31/ledit/README0000644000000000000000000000103611553072337011214 0ustar OVERVIEW: Ledit is a line editor, allowing to use control commands like in emacs or in shells (bash, tcsh). To be used with interactive commands. It is written in Ocaml and Camlp4 and uses the library unix.cma. This is the version 1.11. COPYRIGHT: All files in this distribution are copyright 2001 Institut National de Recherche en Informatique et Automatique (INRIA). FILE: ledit.tar.gz the sources and the manual page BUG REPORTS AND USER FEEDBACK: Send your bug reports by E-mail to: daniel.de_rauglaudre@inria.fr ara-1.0.31/ledit/ledit.ml0000644000000000000000000006566611553072337012012 0ustar (***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: ledit.ml,v 1.21 2001/07/03 11:38:53 ddr Exp $ *) open Sys let max_len = ref 70 let set_max_len x = max_len := if x > 3 then x else failwith "set_max_len" let prompt = ref "" let son = ref None let set_son pid = son := Some pid type command = Abort | Accept_line | Backward_char | Backward_delete_char | Backward_kill_word | Backward_word | Beginning_of_history | Beginning_of_line | Capitalize_word | Delete_char | Downcase_word | End_of_history | End_of_line | Expand_abbrev | Forward_char | Forward_word | Interrupt | Kill_line | Kill_word | Next_history | Operate_and_get_next | Previous_history | Quit | Quoted_insert | Refresh_line | Reverse_search_history | Self_insert | Start_digit_sequence of int | Start_csi_sequence | Start_escape_sequence | Start_o_sequence | Suspend | Transpose_chars | Unix_line_discard | Upcase_word | Yank type istate = Normal | Quote | Escape | CSI | Oseq | Digitseq of int let (command_of_char, set_char_command) = let command_vect = Array.create 256 Self_insert in (fun c -> command_vect.(Char.code c)), (fun c comm -> command_vect.(Char.code c) <- comm) let (escape_command_of_char, set_escape_command) = let command_vect = Array.create 256 Abort in (fun c -> command_vect.(Char.code c)), (fun c comm -> command_vect.(Char.code c) <- comm) let (csi_command_of_char, set_csi_command) = let command_vect = Array.create 256 Abort in (fun c -> command_vect.(Char.code c)), (fun c comm -> command_vect.(Char.code c) <- comm) let (o_command_of_char, set_o_command) = let command_vect = Array.create 256 Abort in (fun c -> command_vect.(Char.code c)), (fun c comm -> command_vect.(Char.code c) <- comm) let (digit_command_of_char, set_digit_command) = let command_vect = Array.init 10 (fun i -> Array.create 256 Abort) in (fun x c -> command_vect.(x).(Char.code c)), (fun x c comm -> command_vect.(x).(Char.code c) <- comm) let _ = set_char_command '\001' Beginning_of_line; set_char_command '\005' End_of_line; set_char_command '\006' Forward_char; set_char_command '\002' Backward_char; set_char_command '\230' Forward_word; set_char_command '\226' Backward_word; set_char_command '\016' Previous_history; set_char_command '\014' Next_history; set_char_command '\188' Beginning_of_history; set_char_command '\190' End_of_history; set_char_command '\018' Reverse_search_history; set_char_command '\004' Delete_char; set_char_command '\008' Backward_delete_char; set_char_command '\127' Backward_delete_char; set_char_command '\020' Transpose_chars; set_char_command '\227' Capitalize_word; set_char_command '\245' Upcase_word; set_char_command '\236' Downcase_word; set_char_command '\228' Kill_word; set_char_command '\136' Backward_kill_word; set_char_command '\255' Backward_kill_word; set_char_command '\017' Quoted_insert; set_char_command '\011' Kill_line; set_char_command '\025' Yank; set_char_command '\021' Unix_line_discard; set_char_command '\012' Refresh_line; set_char_command '\007' Abort; set_char_command '\003' Interrupt; set_char_command '\026' Suspend; set_char_command '\028' Quit; set_char_command '\n' Accept_line; set_char_command '\024' Operate_and_get_next; set_char_command '\027' Start_escape_sequence; set_char_command '\175' Expand_abbrev; set_escape_command 'f' Forward_word; set_escape_command 'b' Backward_word; set_escape_command 'c' Capitalize_word; set_escape_command 'u' Upcase_word; set_escape_command 'l' Downcase_word; set_escape_command '<' Beginning_of_history; set_escape_command '>' End_of_history; set_escape_command 'd' Kill_word; set_escape_command '\008' Backward_kill_word; set_escape_command '\127' Backward_kill_word; set_escape_command '[' Start_csi_sequence; set_escape_command 'O' Start_o_sequence; set_escape_command '/' Expand_abbrev; set_csi_command 'A' Previous_history; set_csi_command 'B' Next_history; set_csi_command 'C' Forward_char; set_csi_command 'D' Backward_char; set_csi_command 'H' Beginning_of_line; set_csi_command 'F' End_of_line; set_csi_command '1' (Start_digit_sequence 1); set_csi_command '3' (Start_digit_sequence 3); set_csi_command '4' (Start_digit_sequence 4); set_csi_command '5' (Start_digit_sequence 5); set_csi_command '6' (Start_digit_sequence 6); set_o_command 'A' Previous_history; set_o_command 'B' Next_history; set_o_command 'C' Forward_char; set_o_command 'D' Backward_char; set_digit_command 1 '~' Beginning_of_line; set_digit_command 3 '~' Delete_char; set_digit_command 4 '~' End_of_line; set_digit_command 5 '~' Backward_word; set_digit_command 6 '~' Forward_word type line = { mutable buf : string; mutable cur : int; mutable len : int } type abbrev_data = { hist : string list; rpos : int; clen : int; abbr : string; found : string list } type state = { od : line; nd : line; line : line; mutable last_line : string; iso_8859_1 : bool; mutable istate : istate; mutable shift : int; mutable cut : string; mutable last_comm : command; mutable histfile : out_channel option; mutable history : string Cursor.t; mutable abbrev : abbrev_data option } let bs = '\b' let put_char st c = output_char stderr c let put_newline st = prerr_endline "" let flush_out st = flush stderr let bell () = prerr_string "\007"; flush stderr let clear_screen () = prerr_string "\027c" let saved_tcio = ref None let init () = saved_tcio := Some( try Unix.tcgetattr Unix.stdin with Unix.Unix_error (_, _, _) -> Printf.eprintf "Error: standard input is not a terminal\n"; flush stderr; exit 1) let edit_tcio = ref None let set_edit () = let tcio = match !edit_tcio with Some e -> e | None -> let tcio = Unix.tcgetattr Unix.stdin in tcio.Unix.c_echo <- false; tcio.Unix.c_icanon <- false; tcio.Unix.c_vmin <- 1; tcio.Unix.c_isig <- false; tcio.Unix.c_ixon <- false; edit_tcio := Some tcio; tcio in Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio and unset_edit () = match !saved_tcio with | Some x -> Unix.tcsetattr Unix.stdin Unix.TCSADRAIN x | None -> invalid_arg "ledit: empty saved_tcio." let line_set_nth_char line i c = if i == String.length line.buf then line.buf <- line.buf ^ String.make 1 c else line.buf.[i] <- c let line_to_nd st = let rec line_rec i = if i == st.line.cur then st.nd.cur <- st.nd.len; if i < st.line.len then let c = st.line.buf.[i] in let ic = Char.code c in if c = '\t' then for i = st.nd.len + 1 to (st.nd.len + 8) / 8 * 8 do line_set_nth_char st.nd st.nd.len ' '; st.nd.len <- st.nd.len + 1 done else if ic < 32 || ic == 127 then begin line_set_nth_char st.nd st.nd.len '^'; line_set_nth_char st.nd (st.nd.len + 1) (Char.chr (127 land (ic + 64))); st.nd.len <- st.nd.len + 2 end else if ic >= 128 && not st.iso_8859_1 then begin line_set_nth_char st.nd st.nd.len '\\'; line_set_nth_char st.nd (st.nd.len + 1) (Char.chr (ic / 100 + Char.code '0')); line_set_nth_char st.nd (st.nd.len + 2) (Char.chr (ic mod 100 / 10 + Char.code '0')); line_set_nth_char st.nd (st.nd.len + 3) (Char.chr (ic mod 10 + Char.code '0')); st.nd.len <- st.nd.len + 4 end else if ic >= 128 && ic < 160 then begin line_set_nth_char st.nd st.nd.len 'M'; line_set_nth_char st.nd (st.nd.len + 1) '-'; line_set_nth_char st.nd (st.nd.len + 2) '^'; line_set_nth_char st.nd (st.nd.len + 3) (Char.chr (127 land (ic + 64))); st.nd.len <- st.nd.len + 4 end else begin line_set_nth_char st.nd st.nd.len c; st.nd.len <- st.nd.len + 1 end; line_rec (i + 1) else if st.nd.len > !max_len then let shift = if st.nd.cur - st.shift >= 0 && st.nd.cur - st.shift < !max_len - 2 then st.shift else if st.nd.cur < !max_len - 3 then 0 else st.nd.cur - !max_len / 2 in for i = 0 to !max_len - 3 do let ni = i + shift in st.nd.buf.[i] <- if ni < st.nd.len then st.nd.buf.[ni] else ' ' done; st.nd.buf.[!max_len - 2] <- ' '; st.nd.buf.[!max_len - 1] <- if shift = 0 then '>' else if st.nd.len - shift < !max_len - 2 then '<' else '*'; st.nd.cur <- st.nd.cur - shift; st.nd.len <- !max_len; st.shift <- shift else st.shift <- 0 in st.nd.len <- 0; line_rec 0 let display st = let rec disp_rec i = if i < st.nd.len then begin if i >= st.od.len || st.od.buf.[i] <> st.nd.buf.[i] then begin while i < st.od.cur do st.od.cur <- st.od.cur - 1; put_char st bs done; while st.od.cur < i do let c = st.nd.buf.[st.od.cur] in st.od.cur <- st.od.cur + 1; put_char st c done; let c = st.nd.buf.[i] in line_set_nth_char st.od i c; st.od.cur <- st.od.cur + 1; put_char st c end; disp_rec (i + 1) end else begin if st.od.len > st.nd.len then begin while st.od.cur < st.od.len do let c = if st.od.cur < st.nd.len then st.nd.buf.[st.od.cur] else ' ' in put_char st c; st.od.cur <- st.od.cur + 1 done; while st.od.cur > st.nd.len do put_char st bs; put_char st ' '; put_char st bs; st.od.cur <- st.od.cur - 1 done end; st.od.len <- st.nd.len; while st.od.cur < st.nd.cur do put_char st st.nd.buf.[st.od.cur]; st.od.cur <- st.od.cur + 1 done; while st.od.cur > st.nd.cur do put_char st bs; st.od.cur <- st.od.cur - 1 done; flush_out st end in disp_rec 0 let update_output st = line_to_nd st; display st let balance_paren st = function ')' | ']' | '}' as c -> let i = let rec find_lparen r i = if i < 0 then i else match st.line.buf.[i] with ')' | ']' | '}' as c -> find_lparen r (find_lparen c (i - 1) - 1) | '(' -> if r == ')' then i else -1 | '[' -> if r == ']' then i else -1 | '{' -> if r == '}' then i else -1 | '\"' -> let rec skip_string i = if i < 0 then i else if st.line.buf.[i] == '\"' then i - 1 else skip_string (i - 1) in find_lparen r (skip_string (i - 1)) | _ -> find_lparen r (i - 1) in find_lparen c (st.line.cur - 2) in if i >= 0 then let c = st.line.cur in st.line.cur <- i; update_output st; st.line.cur <- c; let _ = Unix.select [Unix.stdin] [] [] 1.0 in () | _ -> () let delete_char st = st.line.len <- st.line.len - 1; for i = st.line.cur to st.line.len - 1 do st.line.buf.[i] <- st.line.buf.[i + 1] done let insert_char st x = for i = st.line.len downto st.line.cur + 1 do line_set_nth_char st.line i st.line.buf.[i - 1] done; st.line.len <- st.line.len + 1; line_set_nth_char st.line st.line.cur x let move_in_word buf e f g = let rec move_rec i = if e i then i else match buf.[i] with 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> f move_rec i | x -> if Char.code x >= 160 then f move_rec i else g move_rec i in move_rec let forward_move line = move_in_word line.buf (fun i -> i == line.len) let backward_move line = move_in_word line.buf (fun i -> i == -1) let forward_word line = let i = line.cur in let i = forward_move line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move line (fun mv i -> mv (i + 1)) (fun _ i -> i) i let backward_word line = let i = line.cur - 1 in let i = backward_move line (fun _ i -> i) (fun mv i -> mv (i - 1)) i in backward_move line (fun mv i -> mv (i - 1)) (fun _ i -> i) i + 1 let get_word_len st = let i = st.line.cur - 1 in i - backward_move st.line (fun mv i -> mv (i - 1)) (fun _ i -> i) i let kill_word st = let i = st.line.cur in let i = forward_move st.line (fun _ i -> i) (fun mv i -> delete_char st; mv i) i in forward_move st.line (fun mv i -> delete_char st; mv i) (fun _ i -> i) i let backward_kill_word st = let k = backward_word st.line in let sh = st.line.cur - k in st.line.len <- st.line.len - sh; for i = k to st.line.len - 1 do st.line.buf.[i] <- st.line.buf.[i + sh] done; k let capitalize_word st = let i = st.line.cur in let i0 = forward_move st.line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move st.line (fun mv i -> let f = if i == i0 then Char.uppercase else Char.lowercase in st.line.buf.[i] <- f st.line.buf.[i]; mv (i + 1)) (fun _ i -> i) i0 let upcase_word st = let i = st.line.cur in let i = forward_move st.line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move st.line (fun mv i -> let f = Char.uppercase in st.line.buf.[i] <- f st.line.buf.[i]; mv (i + 1)) (fun _ i -> i) i let downcase_word st = let i = st.line.cur in let i = forward_move st.line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move st.line (fun mv i -> let f = Char.lowercase in st.line.buf.[i] <- f st.line.buf.[i]; mv (i + 1)) (fun _ i -> i) i let transpose_chars st = if st.line.cur == st.line.len then let c = st.line.buf.[st.line.cur - 1] in st.line.buf.[st.line.cur - 1] <- st.line.buf.[st.line.cur - 2]; st.line.buf.[st.line.cur - 2] <- c else let c = st.line.buf.[st.line.cur] in st.line.buf.[st.line.cur] <- st.line.buf.[st.line.cur - 1]; st.line.buf.[st.line.cur - 1] <- c; st.line.cur <- st.line.cur + 1 let set_line st str = st.line.len <- 0; st.line.cur <- 0; for i = 0 to String.length str - 1 do insert_char st str.[i]; st.line.cur <- st.line.len done let save_if_last st = if Cursor.is_last_line st.history then st.last_line <- String.sub st.line.buf 0 st.line.len let previous_history st = try save_if_last st; Cursor.before st.history; set_line st (Cursor.peek st.history) with Cursor.Failure -> bell () let next_history st = try Cursor.after st.history; set_line st (Cursor.peek st.history) with Cursor.Failure -> set_line st st.last_line let read_char = let buff = " " in fun () -> let len = Unix.read Unix.stdin buff 0 1 in if len == 0 then raise End_of_file else buff.[0] let reverse_search_history st = let question str = "(reverse-i-search)'" ^ str ^ "': " in let make_line str fstr = st.line.cur <- 0; st.line.len <- 0; let len = String.length str in for i = 0 to len - 1 do insert_char st str.[i]; st.line.cur <- st.line.cur + 1 done; let len = String.length fstr in for i = 0 to len - 1 do insert_char st fstr.[i]; st.line.cur <- st.line.cur + 1 done in let initial_str = String.sub st.line.buf 0 st.line.len in let rec find_line (cnt, fstr) str = let rec find_rec ifstr istr = if istr == String.length str then cnt, fstr else if ifstr == String.length fstr then if try Cursor.before st.history; true with Cursor.Failure -> false then find_line (cnt + 1, Cursor.peek st.history) str else begin bell (); cnt, fstr end else if str.[istr] != fstr.[ifstr] then find_rec (ifstr + 1) 0 else find_rec (ifstr + 1) (istr + 1) in find_rec 0 0 in let rec incr_search (cnt, fstr) str = let q = question str in make_line q fstr; st.line.cur <- String.length q - 3; update_output st; let c = read_char () in match command_of_char c with Start_escape_sequence -> fstr | Self_insert -> let str = str ^ String.make 1 c in incr_search (find_line (cnt, fstr) str) str | Backward_delete_char -> if String.length str == 0 then incr_search (cnt, fstr) str else let str = String.sub str 0 (String.length str - 1) in for i = 1 to cnt do Cursor.after st.history done; incr_search (find_line (0, initial_str) str) str | Abort -> for i = 1 to cnt do Cursor.after st.history done; bell (); initial_str | Reverse_search_history -> let (cnt, fstr) = try Cursor.before st.history; find_line (cnt + 1, Cursor.peek st.history) str with Cursor.Failure -> bell (); cnt, initial_str in incr_search (cnt, fstr) str | _ -> fstr in let fstr = incr_search (0, initial_str) "" in make_line "" fstr let rec beginning_of_history st = save_if_last st; Cursor.goto_first st.history; try set_line st (Cursor.peek st.history) with Cursor.Failure -> bell () let rec end_of_history st = Cursor.goto_last st.history; set_line st st.last_line let rec back_search st ad hist rpos = match hist with [] -> for i = 0 to String.length ad.abbr - 1 do insert_char st ad.abbr.[i]; st.line.cur <- st.line.cur + 1 done; bell () | l :: ll -> let i = String.length l - rpos in if i <= 0 then back_search st ad ll 0 else let i = backward_word {buf = l; cur = i; len = String.length l} in if String.length l - i < String.length ad.abbr then back_search st ad (l :: ll) (String.length l - i) else if String.sub l i (String.length ad.abbr) = ad.abbr then let i1 = forward_word {buf = l; cur = i; len = String.length l} in let f = String.sub l i (i1 - i) in if List.mem f ad.found then back_search st ad (l :: ll) (String.length l - i) else let ad = {hist = l :: ll; rpos = String.length l - i1; clen = i1 - i; abbr = ad.abbr; found = f :: ad.found} in st.abbrev <- Some ad; for i = 0 to String.length f - 1 do insert_char st f.[i]; st.line.cur <- st.line.cur + 1 done else back_search st ad (l :: ll) (String.length l - i) let expand_abbrev st abbrev = let ad = match abbrev with Some x -> x | None -> let len = get_word_len st in let abbr = String.sub st.line.buf (st.line.cur - len) len in let line_beg = String.sub st.line.buf 0 (st.line.cur - len) in let line_end = String.sub st.line.buf st.line.cur (st.line.len - st.line.cur) in {hist = line_beg :: (Cursor.get_all st.history @ [line_end]); rpos = 0; clen = len; abbr = abbr; found = [abbr]} in for i = 1 to ad.clen do st.line.cur <- st.line.cur - 1; delete_char st done; back_search st ad ad.hist ad.rpos; update_output st let rec update_line st comm c = let abbrev = st.abbrev in st.abbrev <- None; match comm with Beginning_of_line -> if st.line.cur > 0 then begin st.line.cur <- 0; update_output st end | End_of_line -> if st.line.cur < st.line.len then begin st.line.cur <- st.line.len; update_output st end | Forward_char -> if st.line.cur < st.line.len then begin st.line.cur <- st.line.cur + 1; update_output st end | Backward_char -> if st.line.cur > 0 then begin st.line.cur <- st.line.cur - 1; update_output st end | Forward_word -> if st.line.cur < st.line.len then begin st.line.cur <- forward_word st.line; update_output st end | Backward_word -> if st.line.cur > 0 then begin st.line.cur <- backward_word st.line; update_output st end | Capitalize_word -> if st.line.cur < st.line.len then begin st.line.cur <- capitalize_word st; update_output st end | Upcase_word -> if st.line.cur < st.line.len then begin st.line.cur <- upcase_word st; update_output st end | Downcase_word -> if st.line.cur < st.line.len then begin st.line.cur <- downcase_word st; update_output st end | Previous_history -> previous_history st; update_output st | Next_history -> next_history st; update_output st | Beginning_of_history -> beginning_of_history st; update_output st | End_of_history -> end_of_history st; update_output st | Reverse_search_history -> reverse_search_history st; update_output st | Delete_char -> if st.line.len = 0 then raise End_of_file; if st.line.cur < st.line.len then begin delete_char st; update_output st end | Backward_delete_char -> if st.line.cur > 0 then begin st.line.cur <- st.line.cur - 1; delete_char st; update_output st end | Transpose_chars -> if st.line.len > 1 && st.line.cur > 0 then begin transpose_chars st; update_output st end | Kill_word -> if st.line.cur < st.line.len then begin st.line.cur <- kill_word st; update_output st end | Backward_kill_word -> if st.line.cur > 0 then begin st.line.cur <- backward_kill_word st; update_output st end | Quoted_insert -> st.istate <- Quote | Start_escape_sequence -> st.istate <- Escape | Start_csi_sequence -> st.istate <- CSI | Start_digit_sequence x -> st.istate <- Digitseq x | Start_o_sequence -> st.istate <- Oseq | Self_insert -> insert_char st c; st.line.cur <- st.line.cur + 1; balance_paren st c; update_output st | Expand_abbrev -> expand_abbrev st abbrev | Refresh_line -> clear_screen (); prerr_string !prompt; st.od.cur <- 0; st.od.len <- 0; update_output st | Kill_line -> st.cut <- String.sub st.line.buf st.line.cur (st.line.len - st.line.cur); if st.line.len > st.line.cur then begin st.line.len <- st.line.cur; update_output st end | Unix_line_discard -> if st.line.cur > 0 then begin st.line.cur <- 0; st.line.len <- 0; update_output st end | Yank -> if String.length st.cut > 0 then begin for i = 0 to String.length st.cut - 1 do insert_char st st.cut.[i]; st.line.cur <- st.line.cur + 1 done; update_output st end | Abort -> bell () | Interrupt -> if st.line.cur > 0 then begin st.line.cur <- 0; st.line.len <- 0; update_output st end; begin match !son with Some pid -> Unix.kill pid Sys.sigint | _ -> () end | Suspend -> unset_edit (); Unix.kill (Unix.getpid ()) Sys.sigtstp; set_edit (); st.od.cur <- 0; st.od.len <- 0; update_output st | Quit -> begin match !son with Some pid -> Unix.kill pid Sys.sigquit | _ -> () end | Operate_and_get_next|Accept_line -> () let save_history st line = let last_line = try Cursor.peek_last st.history with Cursor.Failure -> "" in if line <> last_line && line <> "" then begin Cursor.insert_last st.history line; match st.histfile with Some fdo -> output_string fdo line; output_char fdo '\n'; flush fdo | None -> () end let (edit_line, open_histfile, close_histfile) = let st = {od = {buf = ""; cur = 0; len = 0}; nd = {buf = ""; cur = 0; len = 0}; line = {buf = ""; cur = 0; len = 0}; last_line = ""; iso_8859_1 = begin try Sys.getenv "LC_CTYPE" <> "" with Not_found -> false end; istate = Normal; shift = 0; cut = ""; last_comm = Accept_line; histfile = None; history = Cursor.create (); abbrev = None} in let edit_line () = let rec edit_loop () = let c = read_char () in let comm = match st.istate with Quote -> Self_insert | Normal -> command_of_char c | Escape -> escape_command_of_char c | CSI -> csi_command_of_char c | Oseq -> o_command_of_char c | Digitseq x -> digit_command_of_char x c in st.istate <- Normal; st.last_comm <- comm; match comm with Accept_line | Operate_and_get_next -> let v_max_len = !max_len in max_len := 10000; update_output st; max_len := v_max_len; put_newline st; let line = String.sub st.line.buf 0 st.line.len in st.abbrev <- None; save_history st line; line | _ -> update_line st comm c; edit_loop () in st.od.len <- 0; st.od.cur <- 0; st.line.len <- 0; st.line.cur <- 0; if st.last_comm == Operate_and_get_next then try Cursor.after st.history; set_line st (Cursor.peek st.history); update_output st with Cursor.Failure -> () else Cursor.goto_last st.history; edit_loop () and open_histfile trunc file = if not trunc then begin match try Some (open_in file) with _ -> None with Some fi -> begin try while true do Cursor.insert st.history (input_line fi) done with End_of_file -> () end; close_in fi | _ -> () end; let fd = Unix.openfile file ([Unix.O_WRONLY; Unix.O_CREAT] @ (if trunc then [Unix.O_TRUNC] else [])) 0o666 in let fdo = Unix.out_channel_of_descr fd in if not trunc then seek_out fdo (out_channel_length fdo); st.histfile <- Some fdo and close_histfile () = match st.histfile with Some fdo -> close_out fdo | None -> () in edit_line, open_histfile, close_histfile let (set_prompt, get_prompt, input_char) = let buff = ref "" and ind = ref 1 in let set_prompt x = prompt := x and get_prompt () = !prompt and input_char ic = if ic != stdin then input_char ic else begin if !ind > String.length !buff then begin prerr_string !prompt; flush stderr; begin try set_edit (); buff := edit_line (); unset_edit () with e -> unset_edit (); raise e end; ind := 0 end; let c = if !ind == String.length !buff then '\n' else !buff.[!ind] in ind := !ind + 1; c end in set_prompt, get_prompt, input_char ;; let read_line = let b = Buffer.create 128 in fun () -> Buffer.clear b; let rec loop () = let c = input_char stdin in if c = '\n' then Buffer.contents b else begin Buffer.add_char b c; loop () end in loop () ara-1.0.31/ledit/README.NEW0000644000000000000000000000060611553072337011646 0ustar This is based on Ledit v1.11. Daniel de Raugladre has kindly given permission to incorporate Ledit in ara. It is not possible for ara to call a pager while being called from Ledit in the usual way. This is why I had to incorporate it. I have reprocessed the input files to remove Daniel's syntax extension and use the old syntax, which I am more familiar with. Berke DURAK, 2004-10-27 ara-1.0.31/ledit/cursor.mli0000644000000000000000000000217211553072337012356 0ustar (***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: cursor.mli,v 1.4 2001/07/03 11:38:53 ddr Exp $ *) type 'a t exception Failure val create : unit -> 'a t val before : 'a t -> unit val after : 'a t -> unit val insert : 'a t -> 'a -> unit val insert_last : 'a t -> 'a -> unit val peek : 'a t -> 'a val peek_last : 'a t -> 'a val goto_first : 'a t -> unit val goto_last : 'a t -> unit val get_all : 'a t -> 'a list val is_last_line : 'a t -> bool ara-1.0.31/ledit/Changes0000644000000000000000000000330111553072337011624 0ustar Ledit Version 1.11 ------------------ - [15 Aut 2001] Added licence (open source) Ledit Version 1.10 ------------------ - [03 Jul 2001] The history now includes also the last input line not yet validated. Ledit Version 1.9 ----------------- - [25 Jun 2001] (internal) Updated for new revised syntax of sequences; added a printer pr_local for the "local" statement Ledit Version 1.8 ----------------- - [08 Jun 2001] Added O-sequences (esc-O) and ^[OA ^[OB ^[OC ^[OD Ledit Version 1.7 ----------------- - Added Transpose_chars (^t) Capitalize_word (M-c or esc c) Upcase_word (M-u or esc u) Downcase_word (M-l or esc l) Ledit Version 1.6 ----------------- - Added hack to avoid Fatal error: uncaught exception Sys_error("Bad file number") which sometimes happens when exiting ledit Ledit Version 1.5 ----------------- - Fixed bug shell prompt sometimes displayed to early when quitting ledit. Ledit Version 1.4 ----------------- - Added M-backspace or M-delete for backward-kill-word - Tabulations are expanded - Fixed bug printing chars between ascii 128 to ascii 159 - "-c" optional: "ledit comm args" <=> "ledit -c comm args" Ledit Version 1.3 ----------------- - Added expand abbrev M-/ - Added suspend ^z - Fixed bug ^l (refresh line) Ledit Version 1.2 ----------------- - Possible use of keyboard arrows - Fixed bug: ^q was not interpreted - If the environment variable LC_CTYPE is iso_8859_1, chars whose code > 128 are printed directly (else using backslash and code number). - Option -v print ledit version and exit. Ledit Version 1.1 ----------------- - First distributed version Wed Feb 19 08:38:38 MET 1997 - Fix bug excessive slowness when pasting as input of ledit ara-1.0.31/ledit/ledit.mli0000644000000000000000000000207711553072337012146 0ustar (***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: ledit.mli,v 1.3 1997/10/28 10:01:04 ddr Exp $ *) val init : unit -> unit val input_char : in_channel -> char val read_line : unit -> string val set_prompt : string -> unit val get_prompt : unit -> string val open_histfile : bool -> string -> unit val close_histfile : unit -> unit val set_max_len : int -> unit val set_son : int -> unit ara-1.0.31/ledit/ledit.l.tpl0000644000000000000000000001064011553072337012411 0ustar .TH LEDIT 1 "Thu Nov 26, 97" "INRIA" .SH NAME ledit \- line editor, version LEDIT_VERSION .SH SYNOPSIS .B ledit [-h \fIfile\fP] [-x] [-l \fIlength\fP] [\fIcommand options\fP] .SH DESCRIPTION The command \fIledit\fP allows to edit lines one by one when running an interactive command. When typing a line, some keys with control or meta are interpreted: it is possible to insert characters in the middle of the line, go to the beginning or the end of the line, get a previous line, search for a line with a pattern, etc. .SH OPTIONS The options are: .TP .B -h \fIfile\fP Save the lines typed (history) in \fIfile\fP. The default is to have them only in memory (so, they are lost at the end of the program). .TP .B -x Extend the history file (given in option "-h") if it already exists. The default is to truncate the history file. .TP .B -v Print ledit version and exit. .TP .B -l \fIlength\fP Tells that \fIlength\fP is the maximum line length displayed. If the line edited is longer than this length, the line scrolls horizontally, while editing. The default value is 70. .TP \fIcommand options\fP Runs the command \fIcommand\fP and its possible options. This must be the last option of ledit. The default value is "cat". .SH KEYS BINDINGS In the following lines, the caret sign "^" means "control" and the sequence "M-" means "meta" (either with the "meta" prefix, or by pressing the "escape" key before). Examples: .TP 1.0i ^a press the "control" key, then press "a", then release "a", then release "control". .TP M-a press the "meta" key, then press "a", then release "a", then release "meta", or: press and release the "escape" key, then press and release "a" (the manipulation with "meta" may not work in some systems: in this case, use the manipulation with "escape"). .PP The editing commands are: .nf ^a : beginning of line ^e : end of line ^f : forward char ^b : backward char M-f : forward word M-b : backard word ^p : previous line in history ^n : next line in history M-< : first line in history M-> : last line in history ^r : reverse search in history (see below) ^d : delete char (or EOF if the line is empty) ^h : (or del or backspace) backward delete char ^t : transpose chars M-c : capitalize word M-u : upcase word M-l : downcase word M-d : kill word M-^h : (or M-del or M-backspace) backward kill word ^q : insert next char M-/ : expand abbreviation ^k : cut until end of line ^y : paste ^u : line discard ^l : refresh line ^g : abort prefix ^c : interrupt ^z : suspend ^\\ : quit return : send line ^x : send line and show next history line other : insert char .fi The arrow keys can be used, providing your keyword returns standard key sequences: .nf up arrow : previous line in history down arrow : next line in history right arrow : forward char left arrow : backward char .SH REVERSE SEARCH The reverse search in incremental, i.e. \fIledit\fP backward searchs in the history a line holding the characters typed. If you type "a", its search the first line before the current line holding an "a" and displays it. If you then type a "b", its search a line holding "ab", and so on. If you type ^h (or backspace), it returns to the previous line found. To cancel the search, type ^g. To find another line before holding the same string, type ^r. To stop the editing and display the current line found, type "escape" (other commands of the normal editing, different from ^h, ^g, and ^r stop the editing too). Summary of reverse search commands: .nf ^g : abort search ^r : search previous same pattern ^h : (or backspace) search without the last char del : search without the last char any other command : stop search and show the line found .fi .SH KNOWN BUGS If \fIledit\fP has been launched in a shell script, the suspend command kills it and its command... Use "exec ledit comm" instead of "ledit comm". .br The suspend command stops \fIledit\fP but not the called program. Do not do this if the called program is not waiting on standard input. .br In some systems (e.g. alpha), pasting two many characters works bad and may block the terminal. Probably a kernel problem. No solution. .SH AUTHOR Daniel de Rauglaudre, at INRIA, france. .br daniel.de_rauglaudre@inria.fr ara-1.0.31/ledit/LICENSE0000644000000000000000000000267411553072337011352 0ustar Copyright (c) 2001, Daniel de Rauglaudre, INRIA. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of INRIA nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ara-1.0.31/ledit/go.ml0000644000000000000000000001033211553072337011272 0ustar (***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: go.ml,v 1.21 2002/04/03 07:37:07 ddr Exp $ *) open Ledit open Sys let version = "1.11" let usage () = prerr_string "Usage: "; prerr_string argv.(0); prerr_endline " [options] [comm [args]]"; prerr_endline " -h file : history file"; prerr_endline " -x : don't remove old contents of history"; prerr_endline " -l len : line max length"; prerr_endline " -v : prints ledit version and exit"; prerr_endline "Exec comm [args] as child process"; exit 1 let get_arg i = if i >= Array.length argv then usage () else argv.(i) let histfile = ref "" let trunc = ref true let comm = ref "cat" let args = ref [| "cat" |] let _ = let rec arg_loop i = if i < Array.length argv then arg_loop (match argv.(i) with "-h" -> histfile := get_arg (i + 1); i + 2 | "-l" -> let x = get_arg (i + 1) in begin try set_max_len (int_of_string x) with _ -> usage () end; i + 2 | "-x" -> trunc := false; i + 1 | "-v" -> Printf.printf "Ledit version %s\n" version; flush stdout; exit 0 | _ -> let i = if argv.(i) = "-c" then i + 1 else i in if i < Array.length argv then begin comm := argv.(i); args := Array.sub argv i (Array.length argv - i); Array.length argv end else Array.length argv) in arg_loop 1 let string_of_signal = function 2 -> "Interrupted" | 3 -> "Quit" | 10 -> "Bus error" | 11 -> "Segmentation fault" | x -> "Signal " ^ string_of_int x let rec read_loop () = begin try match input_char stdin with '\n' -> print_newline () | x -> print_char x with Break -> () end; read_loop () let stupid_hack_to_avoid_sys_error_at_exit () = Unix.dup2 (Unix.openfile "/dev/null" [Unix.O_WRONLY] 0) Unix.stdout let go () = let (id, od) = Unix.pipe () in let pid = Unix.fork () in if pid < 0 then failwith "fork" else if pid > 0 then begin Unix.dup2 od Unix.stdout; Unix.close id; Unix.close od; set_son pid; let _ = (signal sigchld (Signal_handle (fun _ -> match snd (Unix.waitpid [Unix.WNOHANG] pid) with Unix.WSIGNALED sign -> prerr_endline (string_of_signal sign); flush stderr; raise End_of_file | _ -> raise End_of_file)) : signal_behavior) in try if !histfile <> "" then open_histfile !trunc !histfile; catch_break true; read_loop (); if !histfile <> "" then close_histfile () with x -> let _ = (signal sigchld Signal_ignore : signal_behavior) in begin try Unix.close Unix.stdout; let _ = Unix.wait () in () with Unix.Unix_error (_, _, _) -> () end; stupid_hack_to_avoid_sys_error_at_exit (); match x with End_of_file -> () | _ -> prerr_string "(ledit) "; flush stderr; raise x end else begin Unix.dup2 id Unix.stdin; Unix.close id; Unix.close od; Unix.execvp !comm !args; failwith "execv" end let handle f a = try f a with Unix.Unix_error (code, fname, param) -> Printf.eprintf "Unix error: %s\nOn function %s %s\n" (Unix.error_message code) fname param; flush stderr; exit 2 | e -> Printexc.catch raise e let _ = handle go () ara-1.0.31/ledit/cursor.ml0000644000000000000000000000431111553072337012202 0ustar (***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: cursor.ml,v 1.5 2001/07/03 11:38:53 ddr Exp $ *) type 'a t = { mutable before : 'a list; mutable current : 'a option; mutable after : 'a list } exception Failure let create () = {before = []; current = None; after = []} let before c = match c.before with [] -> raise Failure | x :: l -> begin match c.current with Some y -> c.after <- y :: c.after | _ -> () end; c.current <- Some x; c.before <- l let after c = match c.current with None -> raise Failure | Some y -> c.before <- y :: c.before; match c.after with [] -> c.current <- None | x :: l -> c.current <- Some x; c.after <- l let is_last_line c = c.current = None let insert c x = begin match c.current with Some y -> c.before <- y :: c.before | None -> () end; c.current <- Some x let insert_last c x = match c.current with Some _ -> c.after <- c.after @ [x] | None -> c.current <- Some x let peek c = match c.current with Some y -> y | None -> raise Failure let peek_last c = let rec peek_rec = function [] -> raise Failure | [x] -> x | _ :: l -> peek_rec l in peek_rec c.after let rec goto_first c = try while true do before c done with Failure -> () let rec goto_last c = try while true do after c done with Failure -> () let get_all c = let end_list = match c.current with Some y -> y :: c.after | None -> c.after in List.rev_append c.before end_list ara-1.0.31/ledit/ledit.spec0000644000000000000000000000123211553072337012307 0ustar # $Id: ledit.spec,v 1.6 2002/04/03 07:37:07 ddr Exp $ Name: ledit Version: 1.11 Release: 1 Packager: Daniel de Rauglaudre Summary: Line editor Source0: ledit-%{version}.tar.gz Copyright: BSD Group: Development/Tools URL: http://cristal.inria.fr/~ddr/ BuildRoot: /var/tmp/ledit %description A line editor for interactive programs. %prep %setup %build make %install mkdir -p $RPM_BUILD_ROOT%{_prefix}/bin $RPM_BUILD_ROOT%{_prefix}/man/manl cp ledit.out $RPM_BUILD_ROOT%{_prefix}/bin/ledit cp ledit.l $RPM_BUILD_ROOT%{_prefix}/man/manl/ledit.l %clean rm -rf $RPM_BUILD_ROOT %files %{_prefix}/bin/ledit %{_prefix}/man/manl/ledit.l ara-1.0.31/mktarbz2.sh0000755000000000000000000000067211553072340011325 0ustar #!/bin/sh VERSION=`sed -n -e '1s/^ara (\([^ ]*\)) .*$/\1/p' debian/changelog` DATE=`date +'%04Y-%02m-%02d'` base=ara-$VERSION dir=/tmp/$base rm -rf /tmp/ara-$VERSION mkdir $dir || exit 1 cp -a . $dir || exit 1 find $dir -type d -name '.svn' -exec rm -rf \{\} \; &>/dev/null find $dir -type f -name '.depend' -exec rm -f \{\} \; &>/dev/null find $dir -type f -name '.*.swp' -exec rm \{\} \; &>/dev/null cd /tmp && tar cjf $dir.tar.bz2 $base ara-1.0.31/util/0000755000000000000000000000000011553101133010173 5ustar ara-1.0.31/util/Makefile0000644000000000000000000000015211553072340011640 0ustar # $Id$ BASE = .. LIB = util LIBS =$(WITHUNIX) SOURCES = util.ml publication.ml include Makefile.library ara-1.0.31/util/publication.ml0000644000000000000000000000531211553072340013046 0ustar (* Publication *) (* $Id$ *) exception No_issue;; type 'a simple_magazine = < unsubscribe : int -> unit; with_last_issue : ('a -> unit) -> unit; publish : [`Everyone|`Except of int] -> 'a -> unit > ;; class ['a] subscription (magazine : 'a simple_magazine) (key : int) ~callback = object(self) val mutable callback : 'a -> unit = callback method cancel : unit = magazine#unsubscribe key method receive (x : 'a) = callback x method with_last_issue (f : 'a -> unit) : unit = magazine#with_last_issue f method set_callback f = callback <- f method publish x = magazine#publish (`Except key) x method tick = try self#with_last_issue callback with | No_issue -> () end ;; class ['a,'b] bundle (s1 : 'a subscription) (s2 : 'b subscription) ~callback = object(self) val mutable a = None val mutable b = None val mutable callback : ('a * 'b) -> unit = callback initializer s1#set_callback (fun x -> a <- Some x; self#tick); s2#set_callback (fun y -> b <- Some y; self#tick) method cancel : unit = s1#cancel; s2#cancel method with_last_issue (f : ('a * 'b) -> unit) : unit = s1#with_last_issue (fun x -> s2#with_last_issue (fun y -> f (x, y))) method tick = match a,b with | (None,_)|(_,None) -> () | (Some x, Some y) -> callback (x, y) method set_callback f = callback <- f end ;; let breakme () = () let id = ref 0 class ['a] magazine = let id = incr id; !id in let mutex = Mutex.create () in let under_lock f = breakme (); Mutex.lock mutex; try let r = f () in Mutex.unlock mutex; r with | x -> Mutex.unlock mutex; raise x in object(self) val mutable issue : 'a option = None val mutable subscribers = [] val mutable id = 0 method publish who x = under_lock (fun () -> issue <- Some x; List.iter (fun (id,s) -> if match who with | `Everyone -> true | `Except key -> id <> key then s#receive x) subscribers) method with_last_issue f = match issue with | None -> raise No_issue | Some x -> f x method subscribe ?(callback=ignore) () : 'a subscription = under_lock (fun () -> let sub = new subscription (self :> 'a simple_magazine) id ~callback in subscribers <- (id,sub)::subscribers; id <- id + 1; begin try self#with_last_issue (fun x -> sub#receive x); with | No_issue -> () end; sub) method unsubscribe id = subscribers <- List.filter (fun (id',_) -> id <> id') subscribers end ;; ara-1.0.31/util/publication.mli0000644000000000000000000000241611553072340013221 0ustar exception No_issue type 'a simple_magazine = < publish : [ `Everyone | `Except of int ] -> 'a -> unit; unsubscribe : int -> unit; with_last_issue : ('a -> unit) -> unit > class ['a] subscription : 'a simple_magazine -> int -> callback:('a -> unit) -> object val mutable callback : 'a -> unit method cancel : unit method publish : 'a -> unit method receive : 'a -> unit method set_callback : ('a -> unit) -> unit method tick : unit method with_last_issue : ('a -> unit) -> unit end class ['a, 'b] bundle : 'a subscription -> 'b subscription -> callback:('a * 'b -> unit) -> object val mutable a : 'a option val mutable b : 'b option val mutable callback : 'a * 'b -> unit method cancel : unit method set_callback : ('a * 'b -> unit) -> unit method tick : unit method with_last_issue : ('a * 'b -> unit) -> unit end val id : int ref class ['a] magazine : object val mutable id : int val mutable issue : 'a option val mutable subscribers : (int * 'a subscription) list method publish : [ `Everyone | `Except of int ] -> 'a -> unit method subscribe : ?callback:('a -> unit) -> unit -> 'a subscription method unsubscribe : int -> unit method with_last_issue : ('a -> unit) -> unit end ara-1.0.31/util/util.mli0000644000000000000000000000265611553072340011673 0ustar val sf : ('a, unit, string) format -> 'a val first_line : string -> string val limit : int -> string -> string val for_all_chars : (char -> bool) -> string -> bool val split_once_at : (char -> bool) -> string -> string * string val is_digit : char -> bool val is_space : char -> bool val parse_strings : string -> string list val split_at : char -> string -> string list val list_intersect : 'a list -> 'a list -> 'a list val once : (unit -> unit) -> unit -> unit val list_has_more_than_one_element : 'a list -> bool val count_lines : string -> int val first_matching_char_from : int -> (char -> bool) -> string -> int val first_matching_char : (char -> bool) -> string -> int val longest_matching_prefix : (char -> bool) -> string -> string * string val remove_leading_spaces : string -> string val delete_first_chars : int -> string -> string val hierarchical : string -> string -> int val wind : ('a -> 'b) -> 'a -> ('c -> 'd) -> 'c -> 'b val list_change_nth : 'a list -> int -> 'a -> 'a list val list_remove_nth : 'a list -> int -> 'a list val word_wrap : out_channel -> ?columns:int -> string -> unit val reg_of_string : string -> string val flip_array : 'a array -> unit val proc_get_rsz_vsz : unit -> int * int val proc_get_free_mem : unit -> int val substitute_variables : (string * string) list -> string -> string val string_of_process_status : string -> Unix.process_status -> string option val list_sub_rev : 'a list -> int -> int -> 'a list ara-1.0.31/util/util.ml0000644000000000000000000002407211553072340011516 0ustar (* Util *) (* $Id: util.ml,v 1.2 2004/10/26 09:44:54 berke Exp $ *) let sf = Printf.sprintf;; (*** first_line *) let first_line = let b = Buffer.create 256 in fun w -> Buffer.clear b; let rec loop i = if i = String.length w or w.[i] = '\n' then Buffer.contents b else begin Buffer.add_char b w.[i]; loop (i + 1) end in loop 0 ;; (* ***) (*** limit *) let limit m w = let n = String.length w in if n <= m then w else if m < 3 then String.make m '.' else (String.sub w 0 (min (m - 3) n))^"..." ;; (* ***) (*** for_all_chars *) let for_all_chars f w = let m = String.length w in let rec loop i = if i = m then true else f w.[i] && loop (i + 1) in loop 0 ;; (* ***) (*** split_once_at *) let split_once_at f s = let m = String.length s in let rec loop1 i = if i = m then raise Not_found else if f s.[i] then loop2 i (i + 1) else loop1 (i + 1) and loop2 i j = if j = m or not (f s.[j]) then (i,j) else loop2 i (j + 1) in try let (i,j) = loop1 0 in (String.sub s 0 i, String.sub s j (m - j)) with | Not_found -> (s, "") ;; (* ***) (*** is_digit *) let is_digit = function | '0'..'9' -> true | _ -> false ;; (* ***) (*** is_space *) let is_space = function | ' '|'\t'|'\n' -> true | _ -> false ;; (* ***) (*** parse_strings *) let parse_strings u = let m = String.length u in let b = Buffer.create m in let rec loop0 r i = if i >= m then List.rev r else match u.[i] with | ' '|'\t'|'\n' -> loop0 r (i + 1) | '"' -> Buffer.clear b; loop2 r (i + 1) | _ -> loop1 r i and loop1 r i = if i = m or is_space u.[i] or u.[i] = '"' then begin let x = Buffer.contents b in Buffer.clear b; loop0 (x::r) i end else begin Buffer.add_char b u.[i]; loop1 r (i + 1) end and loop2 r i = if i = m then invalid_arg "Unterminated double quote" else if u.[i] = '"' then begin let x = Buffer.contents b in Buffer.clear b; loop0 (x::r) (i + 1) end else if u.[i] = '\\' then if i + 1 < m then match u.[i + 1] with | '\\' -> Buffer.add_char b '\\'; loop2 r (i + 2) | 'n' -> Buffer.add_char b '\n'; loop2 r (i + 2) | 'r' -> Buffer.add_char b 'r'; loop2 r (i + 2) | '"' -> Buffer.add_char b '"'; loop2 r (i + 2) | 't' -> Buffer.add_char b 't'; loop2 r (i + 2) | '0'..'9' -> if i + 3 < m then let x = int_of_string (String.sub u (i + 1) 3) in if 0 < x && x < 256 then begin Buffer.add_char b (Char.chr x); loop2 r (i + 4) end else invalid_arg "Bad or null character code in backslash code" else invalid_arg "Unterminated decimal backslash code" | _ -> invalid_arg "Unknown backslash code" else invalid_arg "Unterminated backslash sequence" else begin Buffer.add_char b u.[i]; loop2 r (i + 1) end in loop0 [] 0 ;; (* ***) (*** split_at *) let split_at c u = let m = String.length u in let b = Buffer.create m in let rec loop0 r i = if i >= m then List.rev r else if u.[i] = c then loop0 r (i + 1) else loop1 r i and loop1 r i = if i = m or u.[i] = c then begin let x = Buffer.contents b in Buffer.clear b; loop0 (x::r) (i + 1) end else begin Buffer.add_char b u.[i]; loop1 r (i + 1) end in loop0 [] 0 ;; (* ***) (*** list_intersect *) let list_intersect l1 l2 = let rec loop r = function | [] -> r | x::y -> loop (if List.mem x l2 then x::r else r) y in loop [] l1 ;; (* ***) (*** once *) let once f = let x = ref true in fun () -> if !x then begin x := false; f () end else () ;; (* ***) (*** list_has_more_than_one_element *) let list_has_more_than_one_element = function | []|[_] -> false | _ -> true ;; (* ***) (*** count_lines *) let count_lines w = let m = String.length w in let rec loop x i = if i = m then x else loop (if w.[i] = '\n' then x + 1 else x) (i + 1) in loop 1 0 ;; (* ***) (*** first_matching_char_from *) let first_matching_char_from i f w = let m = String.length w in let rec loop i = if i = m then raise Not_found else if f w.[i] then i else loop (i + 1) in loop i ;; (* ***) (*** first_matching_char *) let first_matching_char = first_matching_char_from 0;; (* ***) (*** longest_matching_prefix *) let longest_matching_prefix f w = try let i = first_matching_char (fun c -> not (f c)) w in String.sub w 0 i, String.sub w i (String.length w - i) with | Not_found -> (w,"") ;; (* ***) (*** remove_leading_spaces *) let remove_leading_spaces w = try let i = first_matching_char (fun c -> not (is_space c)) w in String.sub w i (String.length w - i) with | Not_found -> w ;; (* ***) (*** delete_first_chars *) let delete_first_chars n w = let m = String.length w in if m > n then String.sub w n (m - n) else "" ;; (* ***) (*** hierarchical *) let hierarchical x y = let m = String.length x and n = String.length y in if m < n then -1 else if m > n then 1 else compare x y ;; (* ***) (*** wind *) let wind f x g y = begin try let r = f x in g y; r with | z -> g y; raise z end ;; (* ***) (*** list_change_nth *) let rec list_change_nth l n z = match l,n with | [],_ -> raise Not_found | x::y,0 -> z::y | x::y,_ -> x::(list_change_nth y (n - 1) z) ;; (* ***) (*** list_remove_nth *) let rec list_remove_nth l n = match l,n with | [],_ -> raise Not_found | x::y,0 -> y | x::y,_ -> x::(list_remove_nth y (n - 1)) ;; (* ***) (*** word_wrap *) let word_wrap oc ?(columns=75) u = let m = String.length u in let f c = output_char oc c and g u i m = output oc u i m in (* beginning of line space *) (* i: current index *) (* j: pending beginning-of-line spaces (i.e., indent) *) let rec loop0 i j = if i = m then if j > 0 then f '\n' else () else match u.[i] with | ' ' -> loop0 (i + 1) (j + 1) | '\t' -> loop0 (i + 1) (j + (4 - j land 3)) | '\n' -> f '\n'; loop0 (i + 1) 0 | _ -> if j < columns then loop2 i i 0 j else begin f '\n'; loop2 i i 0 0 end (* inter-word space *) (* i: current index *) (* j: actual column *) and loop1 i j = if i = m then if j > 0 then f '\n' else () else match u.[i] with | ' '|'\t' -> loop1 (i + 1) j | '\n' -> f '\n'; loop0 (i + 1) 0 | _ -> loop2 i i j 1 (* word *) (* i0: index of beginning of word *) (* i: current index *) (* j: actual cursor column *) (* k: number of pending spaces *) and loop2 i0 i j k = if i = m or u.[i] = ' ' or u.[i] = '\t' or u.[i] = '\n' then let l = i - i0 in if j + k + l >= columns then begin f '\n'; g u i0 l; if i < m & u.[i] = '\n' then begin f '\n'; loop0 (i + 1) 0 end else if l >= columns then begin f '\n'; loop1 (i + 1) 0 end else loop1 (i + 1) l end else begin for h = 1 to k do f ' ' done; g u i0 l; if u.[i] = '\n' then begin f '\n'; loop0 (i + 1) 0 end else loop1 (i + 1) (j + k + l) end else loop2 i0 (i + 1) j k in loop0 0 0 ;; (* ***) (*** reg_of_string *) let reg_of_string w = let m = String.length w in let b = Buffer.create m in for i = 0 to m - 1 do match w.[i] with | ('.'|'+'|'?'|'['|']'|'^'|'$'|'\\') as c -> Buffer.add_char b '\\'; Buffer.add_char b c | '*' -> Buffer.add_string b ".*" | c -> Buffer.add_char b c done; Buffer.contents b ;; (* ***) (*** flip_array *) let flip_array a = let m = Array.length a in for i = 0 to m / 2 - 1 do let t = a.(i) in a.(i) <- a.(m - 1 - i); a.(m - 1 - i) <- t done ;; (* ***) (*** proc_get_free_mem *) let proc_get_free_mem () = let ic = open_in "/proc/meminfo" in wind (fun () -> let tot = ref 0 in try while true do let l = input_line ic in match split_at ' ' l with | [("MemFree:"|"Cached:");x;"kB"] -> tot := (int_of_string x) + !tot | _ -> () done; assert false with | End_of_file -> !tot | _ -> 16384 (* assumption *)) () (fun () -> close_in ic) () ;; (* ***) (*** proc_get_rsz_vsz *) let proc_get_rsz_vsz () = let ic = open_in (sf "/proc/%d/statm" (Unix.getpid ())) in wind (fun () -> Scanf.fscanf ic "%d %d %d %d %d %d %d" (fun size resident share trs drs lrs dt -> (resident,share))) () (fun () -> close_in ic) () ;; (* ***) (*** substitute_variables *) let substitute_variables env w = let b = Buffer.create (String.length w) in Buffer.add_substitute b (fun v -> List.assoc v env) w; Buffer.contents b ;; (* ***) (*** string_of_process_status *) let string_of_process_status thing = function | Unix.WEXITED(rc) -> if rc <> 0 then Some(sf "%s failed with code %d" thing rc) else None | Unix.WSIGNALED(sg) -> Some(sf "%s exited with signal %d" thing sg) | Unix.WSTOPPED(sg) -> Some(sf "%s stopped with signal %d" thing sg) ;; (* ***) (*** list_sub_rev *) let list_sub_rev l start stop = let rec loop r j = function | [] -> r (* shall we raise an exception ? *) | x::y -> loop (if j < start or j > stop then r else x::r) (j + 1) y in loop [] 0 l ;; (* ***) ara-1.0.31/COPYING0000644000000000000000000004312711553072340010267 0ustar GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License.