/pliant/protocol/http/style/common.style
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	module "/pliant/language/stream.pli"
17	module "/pliant/language/stream/filesystembase.pli"
18	module "/pliant/language/compiler.pli"
19	module "/pliant/language/parser.pli"
20	module "/pliant/admin/file.pli"
21	module "/pliant/protocol/http/server.pli"
22	module "/pliant/protocol/common/mime.pli"
23	module "common.pli"
24
25
26
27	#  basic
28
29
30	method p replace_content replace with -> status
31	arg_rw HtmlPage p ; arg Str replace with ; arg Status status
32	var Pointer:Stream stream :> p http_stream
33	var Address start := stream stream_write_buf
34	var Address cur := stream stream_write_cur
35	var Address stop := stream stream_write_stop
36	if (cast stop Int).-.(cast cur Int) >= with:len-replace:len
37	var Address a := memory_search start (cast cur Int).-.(cast start Int) replace:characters replace:len
38	if a<>null
39	memory_move (a translate Byte replace:len) (a translate Byte with:len) (cast cur Int).-.(cast a Int)-replace:len
40	memory_copy with:characters a with:len
41	stream stream_write_cur := cur translate Byte with:len-replace:len
42	return success
43	status := failure
44
45	method p head s -> status
46	arg_rw HtmlPage p ; arg Str s ; arg Status status
47	p replace_content "</head>" s+"</head>"
48
49	method p flush
50	arg_rw HtmlPage p
51	p:http_stream flush anytime
52
53	function 'cast Status' p -> s
54	arg HtmlPage p ; arg Status s
55	s := cast p:http_stream Status
56
57
58	method p virtual_command -> c
59	arg HtmlPage p ; arg_C Str c
60	c :> p:http_request command
61
62
63	method p language -> l
64	arg HtmlPage p ; arg_C Str l
65	l :> p:http_request language
66
67
68	export '. replace_content' '. head' '. flush' 'cast Status' '. virtual_command' '. language'
69
70
71
72	#  authentification
73
74
75	method p user_name -> u
76	arg HtmlPage p ; arg Str u
77	u := p:request user_name
78
79	method p allowed name -> a
80	arg HtmlPage p ; arg Str name ; arg CBool a
81	a := p:request allowed name
82
83	method p is_not_allowed name -> failed
84	arg_rw HtmlPage p ; arg Str name ; arg CBool failed
85	failed := not (p:request allowed name)
86	if failed
87	p reset_http_answer
88	p:request send_authentification_request
89
90	meta requires e
91	if e:size=1 and (e:0 cast Str)
92	e compile_as (expression immediat (if is_not_allowed:name return) substitute name e:0)
93
94	export '. user_name' '. allowed' requires '. is_not_allowed'
95
96
97
98	#  [] inline text
99
100
101	function active_type itext access e
102	arg InlineText itext ; arg Int access ; arg_rw Expression e
103	if ("[dq]"+(addressof:itext map Str)+"[dq]" parse (var Str t))
104	var Link:Str text :> new Str t
105	if e:size=0
106	e compile_as (expression immediat (page text t) substitute t (expression constant text near e))
107
108
109
110	# driving the browser
111
112
113	method page goto_hyperlink target autoext section options
114	arg_rw HtmlPage page ; arg Str target ; arg CBool autoext ; arg Str section options
115	var Str without_path := target (target search_last "/" -1)+1 target:len
116	var Str t := http_encode target
117	if autoext and without_path:len<>0 and (without_path search "." -1)=(-1) and (without_path search ":" -1)=(-1)
118	t += ".html"
119	if section<>""
120	t += "#"+http_encode:section
121	if options<>""
122	t += "?"+http_encode:options
123	page:http_request answer_is_dynamic := true
124	page html "<script language=[dq]JavaScript[dq]>[lf]"
125	page html "  location.replace([dq]"+t+"[dq])[lf]"
126	page html "</script>[lf]"
127	page html "Your browser is not very smart. You should select <a href=[dq]"+t+"[dq]>this link</a> to get the right page."
128
129	meta '. goto_url' e
130	if e:size<2 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
131	return
132	e suckup e:0 ; e suckup e:1
133	var Link:Argument autoext :> argument constant CBool true
134	var Link:Argument section :> argument constant Str ""
135	var Link:Argument options :> argument constant Str ""
136	var Int i := 2
137	while i<e:size
138	if e:i:ident="no_extension"
139	autoext :> argument constant CBool false
140	i += 1
141	eif e:i:ident="section" and i+1<e:size and (e:(i+1) cast Str)
142	e suckup e:(i+1)
143	section :> e:(i+1):result
144	i += 2
145	eif e:i:ident="options" and i+1<e:size and (e:(i+1) cast Str)
146	e suckup e:(i+1)
147	options :> e:(i+1):result
148	i += 2
149	else
150	return
151	e add (instruction (the_function '. goto_hyperlink' HtmlPage Str CBool Str Str) e:0:result e:1:result autoext section options)
152	e set_void_result
153
154
155	method page goto_backward n
156	arg_rw HtmlPage page ; arg Int n
157	page:http_request answer_is_dynamic := true
158	page html "<script language=[dq]JavaScript[dq]>[lf]"
159	var Int x := undefined ; var Int y := undefined
160	part search
161	if n=0
162	if ("&"+page:http_request:form+"&" eparse any "&_pliant_x=" (var Int x) "&" any) and ("&"+page:http_request:form+"&" eparse any "&_pliant_y=" (var Int y) "&" any)
163	leave search
164	eif (page:http_request:encoded_options parse "button+" (var Int x) "+" (var Int y) "+" any)
165	leave search
166	eif n=1
167	var Pointer:Arrow c :> page:http_request:query_log first
168	while c<>null
169	if ((c map Str) parse acword:"referer" ":" any "?button+" x "+" y "+" any)
170	leave search
171	c :> page:http_request:query_log next c
172	if x=defined and y=defined
173	var Str spos := (character 65+x\17576)+(character 65+x\676%26)+(character 65+x\26%26)+(character 65+x%26)+(character 65+y\17576)+(character 65+y\676%26)+(character 65+y\26%26)+(character 65+y%26)
174	page html "    window.name = '_xy_"+spos+"_'+window.name[lf]"
175	if page:http_request:browser_model="netscape"
176	page html "  window.history.go(-"+(string n+1)+")[lf]"
177	eif page:http_request:browser_model="ie" and page:http_request:browser_release<6 or page:http_request:browser_model="mozilla" and page:http_request:browser_release>=1.5
178	page html "  window.name = '_reload_'+window.name[lf]"
179	page html "  window.history.go(-"+(string n+1)+")[lf]"
180	else # Mozilla 0.9.8, IE 6, Opera 6 and Konqueror, FireFox <1.5
181	page html "  window.name = '_back_"+(character 65+n)+"__reload_'+window.name[lf]"
182	page html "</script>[lf]"
183	page html "<p>Now computing ...</p><p><font size=[dq]-1[dq]>If your browser is not smart enough to switch back automatically when the computation is over, then you'll have to press the Back button "+(string n+1)+" time"+(shunt n>=1 "s" "")+" and then the reload button.</font></p>"
184
185	method page reload_page
186	arg_rw HtmlPage page
187	page goto_backward 0
188
189	method page goto_backward
190	arg_rw HtmlPage page
191	page goto_backward 1
192
193
194	export '. goto_url' '. reload_page' '. goto_backward'
195
196
197
198
199