1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
(* $Id: doc.ml,v 4.5 2002/12/30 18:40:04 ddr Exp $ *)
open Config;
value start_with s i p =
i + String.length p < String.length s &&
String.lowercase (String.sub s i (String.length p)) = p
;
value last_is s i p =
loop i (String.length p - 1) where rec loop i k =
if i <= 0 then False
else if k < 0 then True
else
let c = Char.lowercase s.[i] in
let c = if c = '\n' || c = '\r' then ' ' else c in
if c = ' ' && p.[k] = ' ' then
let rec loop1 i =
if i <= 0 then False
else
match s.[i] with
[ '\n' | '\r' | ' ' -> loop1 (i - 1)
| _ -> loop i (k - 1) ]
in
loop1 (i - 1)
else if c = p.[k] then loop (i - 1) (k - 1)
else False
;
value http = "http://";
value url_basename name =
try
let p = String.rindex name '/' + 1 in
String.sub name p (String.length name - p)
with
[ Not_found -> name ]
;
value url_dirname name =
try
match String.rindex name '/' with
[ 0 -> "/"
| n -> String.sub name 0 n ]
with
[ Not_found -> "." ]
;
value string_contains s ss =
let sslen = String.length ss in
let mlen = String.length s - sslen in
loop 0 where rec loop i =
if i >= mlen then False
else if String.sub s i sslen = ss then True
else loop (i + 1)
;
value url_is_relative n = String.length n < 1 || n.[0] <> '/';
value url_is_implicit n =
url_is_relative n && not (string_contains n "./") &&
not (string_contains n "../") && not (string_contains n ".\\") &&
not (string_contains n "..\\") && not (string_contains n ":") &&
not (string_contains n "::")
;
value copy conf pref_doc pref_img s =
loop 0 where rec loop i =
if i == String.length s then ()
else if last_is s i "<a href=" then do {
let i = do { Wserver.wprint "="; i + 1 } in
let i = if s.[i] = '"' then do { Wserver.wprint "\""; i + 1 } else i in
if s.[i] = '#' || start_with s i http || start_with s i "mailto:" then
()
else Wserver.wprint "%s" pref_doc;
loop i
}
else if last_is s i " src=" || last_is s i " background=" then do {
let i = do { Wserver.wprint "="; i + 1 } in
let (img, i) =
if s.[i] = '"' then
let rec loop i len =
if i = String.length s then (Buff.get len, i)
else if s.[i] = '"' then (Buff.get len, i + 1)
else loop (i + 1) (Buff.store len s.[i])
in
loop (i + 1) 0
else
let rec loop i len =
if i = String.length s then (Buff.get len, i)
else if s.[i] = '>' then (Buff.get len, i)
else loop (i + 1) (Buff.store len s.[i])
in
loop (i + 1) 0
in
let img = url_basename img in
Wserver.wprint "\"%s%s\"" pref_img img;
loop i
}
else if last_is s i "<body>" then do {
Wserver.wprint "%s>" (Util.body_prop conf); loop (i + 1)
}
else do { Wserver.wprint "%c" s.[i]; loop (i + 1) }
;
value mac_name_of_url_name s =
loop 0 0 where rec loop i len =
if i == String.length s then Buff.get len
else if s.[i] == '/' then loop (Buff.store len ':') (i + 1)
else loop (Buff.store len s.[i]) (i + 1)
;
value print conf =
let v =
match Util.p_getenv conf.env "v" with
[ Some f -> f
| None -> "" ]
in
let v = if v = "" then "index.htm" else v in
if url_is_implicit v then
let fname = if Sys.os_type = "MacOS" then mac_name_of_url_name v else v in
let fname =
if Filename.check_suffix fname ".htm" then fname else fname ^ ".htm"
in
let fname = Filename.concat Util.doc_dir.val fname in
match try Some (open_in fname) with [ Sys_error _ -> None ] with
[ Some ic ->
do {
Util.html conf;
Util.nl ();
let s =
let len = ref 0 in
do {
try
let rec loop () =
do {
len.val := Buff.store len.val (input_char ic); loop ()
}
in
loop ()
with
[ End_of_file -> close_in ic ];
Buff.get len.val
}
in
let pref_doc =
let dir = url_dirname v ^ "/" in
let dir = if dir = "./" then "" else dir in
conf.indep_command ^ "m=DOC;v=" ^ dir
in
let pref_img = conf.indep_command ^ "m=IM;v=/" in
copy conf pref_doc pref_img s
}
| None -> Util.incorrect_request conf ]
else Util.incorrect_request conf
;
|
