cvs snapshot Tue, 26 Nov 2002 18:41:34 +0100

diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml
index 2ecf95518e9d77c841ebbb43e770012b080c5c47..d45045b5d56197746853475c48a6373512af9fe9 100644 (file)
--- a/helm/uwobo/src/ocaml/uwobo.ml
+++ b/helm/uwobo/src/ocaml/uwobo.ml
@@ -60,6 +60,7 @@ in
 
   (* values common to all threads *)
 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
+syslogger#enable;
 let styles = new Uwobo_styles.styles in
 let styles_mutex = Mutex.create () in
 let usage_string = "Help message: not yet written!!" in (* TODO *)
@@ -67,9 +68,10 @@ let usage_string = "Help message: not yet written!!" in (* TODO *)
   (* thread action *)
 let callback req outchan =
   try
+    syslogger#log `Debug (sprintf "Received request: %s" req#path);
     (match req#path with
     | "/add" ->
-        (let bindings = req#param_all "bind" in
+        (let bindings = req#paramAll "bind" in
         if bindings = [] then
           invocation_error "No [key,stylesheet] binding provided" outchan
         else begin
@@ -95,7 +97,12 @@ let callback req outchan =
         end)
     | "/remove" ->  (* TODO this branch is almost identical to "/reload" one *)
         (let log = new Uwobo_logger.processingLogger () in
-        (match (Pcre.split ~pat:"," (req#param "keys")) with
+        let keys =
+          try
+            Pcre.split ~pat:"," (req#param "keys")
+          with Http_request.Param_not_found _ -> []
+        in
+        (match keys with
         | [] -> (* no key provided, unload all stylesheets *)
             log#log "removing all stylesheets ...";
             Mutex.lock styles_mutex;
@@ -129,7 +136,12 @@ let callback req outchan =
         Http_daemon.respond ~body:log#asHtml outchan)
     | "/reload" ->  (* TODO this branch is almost identical to "/remove" one *)
         (let log = new Uwobo_logger.processingLogger () in
-        (match (Pcre.split ~pat:"," (req#param "keys")) with
+        let keys =
+          try
+            Pcre.split ~pat:"," (req#param "keys")
+          with Http_request.Param_not_found _ -> []
+        in
+        (match keys with
         | [] -> (* no key provided, reload all stylesheets *)
           log#log "reloading all stylesheets ...";
           Mutex.lock styles_mutex;
@@ -163,49 +175,33 @@ let callback req outchan =
         (* notation: "local" parameters are those defined on a per-stylesheet
         pasis (i.e. param.key.param=value), "global" parameters are those
         defined for all stylesheets (i.e. param.param=value) *)
-        let local_params = ref [] in  (* association list <key, parameters> *)
-        let global_params = ref [] in (* association list <name, value> *)
-        let properties = ref [] in    (* association list <name, value> *)
-        let get_style_param key name =
-          let params =  (* try local params and fallback on global params *)
-            try List.assoc key !local_params with Not_found -> global_params
-          in
-          List.assoc name !params  (* may raise Not_found *)
-        in
-        let get_property name = List.assoc name !properties in
-        let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}" x in
-        let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}" x in
-        let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+" x in
-        let add_global_param name value =
-          let name = Pcre.replace ~pat:"^param\\." name in
-          global_params := (name, value) :: !global_params
-        in
-        let add_local_param name value =
-          let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
-          let (key, param) = (pieces.(1), pieces.(2)) in
-          (try
-            let previous_params = List.assoc key !local_params in
-            let new_params = (param, value) :: previous_params in
-            local_params := new_params :: (List.remove_assoc key !local_params)
-          with Not_found -> (* first local parameter for 'key' *)
-            local_params := [(param, value)] :: !local_params)
-        in
-        let add_property name value =
-          properties :=
-            (Pcre.replace ~pat:"^prop\\." name, value) :: !properties
+        let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
+        let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
+        let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
+        let (params, props) =
+          List.fold_left
+            (fun (old_params, old_properties) (name, value) ->
+              match name with
+              | name when is_global_param name ->
+                  let name = Pcre.replace ~pat:"^param\\." name in
+                  ((fun x -> (old_params x) @ [name, value]),
+                   old_properties)
+              | name when is_local_param name ->
+                  let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
+                  let (key, name) = (pieces.(1), pieces.(2)) in
+                  ((function
+                    | x when x = key -> [name, value] @ (old_params x)
+                    | x -> old_params x),
+                   old_properties)
+              | name when is_property name ->
+                  let name = Pcre.replace ~pat:"^prop\\." name in
+                  (old_params, ((name, value) :: old_properties))
+              | _ -> (old_params, old_properties))
+            ((fun _ -> []), []) (* no parameters, no properties *)
+            req#params
         in
-        List.iter
-          (fun (name, value) ->
-            match name with
-            | name when is_global_param name -> add_global_param name value
-            | name when is_local_param name -> add_local_param name value
-            | name when is_property name -> add_property name value
-            | _ -> ())
-          req#params;
         Uwobo_engine.apply
-          ~logger ~styles ~keys ~input:xmluri
-          ~params:get_style_param ~props:get_property
-          outchan)
+          ~logger ~styles ~keys ~input:xmluri ~params ~props outchan)
     | "/help" -> Http_daemon.respond ~body:usage_string outchan
     | invalid_request ->
         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
@@ -221,8 +217,8 @@ in
   (* daemon initialization *)
 syslogger#log
   `Notice
-  (sprintf "%s started and listening on port %d\n" daemon_name port);
-syslogger#log `Notice (sprintf "current directory is %s\n" (Sys.getcwd ()));
+  (sprintf "%s started and listening on port %d" daemon_name port);
+syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 Http_daemon.start' ~port ~mode:`Thread callback;
-syslogger#log `Notice (sprintf "%s is terminating, bye!\n" daemon_name)
+syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 

diff --git a/helm/uwobo/src/ocaml/uwobo_logger.ml b/helm/uwobo/src/ocaml/uwobo_logger.ml
index c0e73b9b95aca9a5c4a883636823234d97b85d4a..b7e4239a6c03df29b83160e38f2b7dfd2fa1de55 100644 (file)
--- a/helm/uwobo/src/ocaml/uwobo_logger.ml
+++ b/helm/uwobo/src/ocaml/uwobo_logger.ml
@@ -27,12 +27,14 @@ let string_of_priority = function
 
 class sysLogger ?(level: priority = `Notice) () =
   object
+    initializer
+      print_endline (sprintf "Logger started with level %s" (string_of_priority level))
     val level_no = int_of_priority level
     val mutable enabled = false
     method enable = enabled <- true
     method disable = enabled <- false
     method log (prio: priority) msg =
-      if enabled && (int_of_priority prio < level_no) then
+      if enabled && (int_of_priority prio <= level_no) then
         prerr_endline (sprintf ("%s: %s") (string_of_priority prio) msg)
   end