(* $Id: index.ml,v 1.1 2003-03-09 17:37:29 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
open Wd_dialog
open Wd_run_cgi
(* IMPORTANT NOTE:
*
* The underlying NDBM implementation is required to allow arbitrary
* long key/value pairs. This is known to be true for GDBM and
* Berkeley DB, but it does not hold for the original Unix implementation.
* Single Unix Spec only demands that NDBM supports at least 1023 bytes
* for key plus value.
*
* The following code does not implement locking for the NDBM accesses.
* This should be added.
*)
let transaction f =
let dbm = Dbm.opendbm "./sessions" [ Dbm.Dbm_create; Dbm.Dbm_rdwr ] 0o666 in
let r = f dbm in
Dbm.close dbm;
r
;;
class dbm_session_manager : session_manager_type =
(* A new session manager that stored sessions into NDBM files. It is derived
* from database_session_manager by implementing the database access
* functions "allocate", "insert", "update", and "lookup".
*)
database_session_manager
~allocate:(fun () ->
transaction
(fun dbm ->
let next_key =
try int_of_string(Dbm.find dbm "nextid")
with Not_found -> 0
in
Dbm.replace dbm "nextid" (string_of_int (next_key+1));
next_key
))
~insert:(fun id skey ->
transaction
(fun dbm ->
let key = string_of_int id ^ ":" ^ skey in
Dbm.replace dbm (key ^ "-val") "";
Dbm.replace dbm (key ^ "-chk") "";
))
~update:(fun id skey value checksum ->
transaction
(fun dbm ->
let key = string_of_int id ^ ":" ^ skey in
try
let _ = Dbm.find dbm (key ^ "-val") in
Dbm.replace dbm (key ^ "-val") value;
Dbm.replace dbm (key ^ "-chk") checksum;
with
Not_found ->
raise Session_not_found))
~lookup:(fun id skey ->
transaction
(fun dbm ->
let key = string_of_int id ^ ":" ^ skey in
try
let value = Dbm.find dbm (key ^ "-val") in
let checksum = Dbm.find dbm (key ^ "-chk") in
(value,checksum)
with
Not_found ->
raise Session_not_found))
()
;;
let read_directory path =
(* Return the file names of the directory "path" as string list *)
let d = Unix.opendir path in
let rec readrec () =
try
let name = Unix.readdir d in
name :: readrec()
with
End_of_file -> []
in
let names = readrec() in
Unix.closedir d;
names
;;
let permissions kind perm =
(* Compute a textual representation of file 'kind' and
* permission mode 'perm'
*)
let first_letter =
match kind with
Unix.S_REG -> "-"
| Unix.S_DIR -> "d"
| Unix.S_CHR -> "c"
| Unix.S_BLK -> "b"
| Unix.S_LNK -> "l"
| Unix.S_FIFO -> "p"
| Unix.S_SOCK -> "s"
in
let s = ref "" in
let p = ref perm in
List.iter
(fun letter ->
begin
if !p mod 2 = 1 then
s := letter ^ !s
else
s := "-" ^ !s
end;
p := !p / 2)
[ "x"; "w"; "r"; "x"; "w"; "r"; "x"; "w"; "r" ];
s := first_letter ^ !s;
if (perm land 0o1000) > 0 then begin
if !s.[9] = 'x' then
!s.[9] <- 't'
else
!s.[9] <- 'T'
end;
if (perm land 0o2000) > 0 then begin
if !s.[6] = 'x' then
!s.[6] <- 's'
else
!s.[6] <- 'l'
end;
if (perm land 0o4000) > 0 then begin
if !s.[6] = 'x' then
!s.[6] <- 's'
else
!s.[6] <- 'S'
end;
!s
;;
let owner uid =
(* Converts the numerical uid to a string *)
try
(Unix.getpwuid uid).Unix.pw_name
with
Not_found -> string_of_int uid
;;
let group gid =
(* Converts the numerical gid to a string *)
try
(Unix.getgrgid gid).Unix.gr_name
with
Not_found -> string_of_int gid
;;
let timestring t =
(* Converts the time value t to a string *)
let tm = Unix.localtime t in
Printf.sprintf
"%04d-%02d-%02d %02d:%02d:%02d"
(tm.Unix.tm_year + 1900) (* Y2k-compliant *)
(tm.Unix.tm_mon + 1)
(tm.Unix.tm_mday)
(tm.Unix.tm_hour)
(tm.Unix.tm_min)
(tm.Unix.tm_sec)
;;
class directory universe name env =
object (self)
inherit Wd_dialog.dialog universe name env
method prepare_page() =
(* Compute the variable "listing": *)
match self # page_name with
"show-listing" ->
self # prepare_show_listing()
| _ ->
()
method private prepare_show_listing() =
let path = self # string_variable "path" in
let names = Sort.list
(fun a b -> a <= b)
(read_directory path) in (* file names *)
(* Get all necessary templates: *)
let t_directory_row = self # t_get "directory-row" in
let t_filename = self # t_get "filename" in
let t_filename_d = self # t_get "filename_d" in
let t0 = Unix.gettimeofday() in
(* Map 'names' to a tree list: *)
let rows =
List.map
(fun name ->
let path_name = Filename.concat path name in
let s = Unix.stat path_name in
let ls = Unix.lstat path_name in
(* If the file is a directory, use t_filename_d instead of
* t_filename:
*)
let t_fname =
match s.Unix.st_kind with
Unix.S_DIR -> t_filename_d
| _ -> t_filename
in
self # t_apply
t_directory_row
[ "filename", self # t_apply
t_fname
[ "value", self # t_text name ];
"fileperms", self # t_text (permissions
s.Unix.st_kind
s.Unix.st_perm);
"fileowner", self # t_text (owner s.Unix.st_uid);
"filegroup", self # t_text (group s.Unix.st_gid);
"filesize", self # t_text (string_of_int s.Unix.st_size);
"filemtime", self # t_text (timestring s.Unix.st_mtime);
"filesymlink",
match ls.Unix.st_kind with
Unix.S_LNK ->
self # t_apply_byname "symlink"
[ "value",
self # t_text (Unix.readlink path_name) ]
| _ -> self # t_empty;
]
)
names
in
let t1 = Unix.gettimeofday() in
(* Concatenate 'rows' and put result into 'listing': *)
self # put_tree "listing" (self # t_concat self#t_empty rows)
method private change_directory dirname =
(* Append [dirname] to the current directory path *)
match dirname with
"." -> ()
| ".." ->
let p = Filename.dirname
(self # string_variable "path") in
self # set_variable "path" (String_value p)
| _ ->
self # set_variable "path"
(String_value
(Filename.concat
(self # string_variable "path")
dirname))
method handle() =
match self # event with
Indexed_button ("goto_dir", dirname) ->
self # change_directory dirname
| Button "confirm" ->
self # change_directory (self # string_variable "next_path")
| Indexed_button("set_language", lang) ->
self # set_variable "lang" (String_value lang)
| Popup_request path ->
(* Executed just before the confirmation_popup appears: *)
self # set_variable "next_path" (String_value path)
| _ -> ()
end
;;
run
~session_manager:(new dbm_session_manager)
~reg:(fun universe ->
universe # register "directory" (new directory)
)
()
;;
(* ======================================================================
* History:
*
* $Log: index.ml,v $
* Revision 1.1 2003-03-09 17:37:29 stolpmann
* Initial revision.
*
*)
