Diff of /branches/rel-2-1-patches/webwork-modperl/lib/WeBWorK/ContentGenerator.pm

Revision 1910		Revision 1911
1	################################################################################	1	################################################################################
2	# WeBWorK Online Homework Delivery System	2	# WeBWorK Online Homework Delivery System
3	# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/	3	# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
4	# $CVSHeader: webwork-modperl/lib/WeBWorK/ContentGenerator.pm,v 1.87 2004/03/15 23:03:46 sh002i Exp $	4	# $CVSHeader: webwork-modperl/lib/WeBWorK/ContentGenerator.pm,v 1.88 2004/03/17 08:15:31 sh002i Exp $
5	#	5	#
6	# This program is free software; you can redistribute it and/or modify it under	6	# This program is free software; you can redistribute it and/or modify it under
7	# the terms of either: (a) the GNU General Public License as published by the	7	# the terms of either: (a) the GNU General Public License as published by the
8	# Free Software Foundation; either version 2, or (at your option) any later	8	# Free Software Foundation; either version 2, or (at your option) any later
9	# version, or (b) the "Artistic License" which comes with this package.	9	# version, or (b) the "Artistic License" which comes with this package.
…		…
41		41
42	=cut	42	=cut
43		43
44	use strict;	44	use strict;
45	use warnings;	45	use warnings;
46	use Apache::Constants qw(:common);	46	use Apache::Constants qw(:response);
47	use Carp;	47	use Carp;
48	use CGI::Pretty qw(ul li);	48	use CGI::Pretty qw(ul li);
49	use URI::Escape;	49	use URI::Escape;
50	use WeBWorK::Template qw(template);	50	use WeBWorK::Template qw(template);
51		51
…		…
106	header. It is defined in this class (see below), but may be overridden in	106	header. It is defined in this class (see below), but may be overridden in
107	subclasses which need to send different header information. For some reason, the	107	subclasses which need to send different header information. For some reason, the
108	return value of header() will be used as the result of this function, if it is	108	return value of header() will be used as the result of this function, if it is
109	defined.	109	defined.
110		110
		111	FIXME: figure out what the deal is with the return value of header(). If we sent
		112	a header, it's too late to set the status by returning. If we didn't, header()
		113	didn't perform its function!
		114
111	=item 3	115	=item 3
112		116
113	At this point, go() will terminate if the request is a HEAD request or if the	117	At this point, go() will terminate if the request is a HEAD request or if the
114	field $self->{noContent} contains a true value.	118	field $self->{noContent} contains a true value.
		119
		120	FIXME: I don't think we'll need noContent after reply_with_redirect() is
		121	adopted by all modules.
115		122
116	=item 4	123	=item 4
117		124
118	If the field $self->{sendFile} is defined, the method sendFile() is called to	125	If the field $self->{sendFile} is defined, the method sendFile() is called to
119	send the specified file to the client, and go() terminates. See below.	126	send the specified file to the client, and go() terminates. See below.
…		…
139		146
140	my $returnValue = OK;	147	my $returnValue = OK;
141		148
142	$self->pre_header_initialize(@_) if $self->can("pre_header_initialize");	149	$self->pre_header_initialize(@_) if $self->can("pre_header_initialize");
143		150
		151	# send a file instead of a normal reply (reply_with_file() sets this field)
		152	defined $self->{reply_with_file} and do {
		153	return $self->do_reply_with_file($self->{reply_with_file});
		154	};
		155
		156	# send a Location: header instead of a normal reply (reply_with_redirect() sets this field)
		157	defined $self->{reply_with_redirect} and do {
		158	return $self->do_reply_with_redirect($self->{reply_with_redirect});
		159	};
		160
144	my $headerReturn = $self->header(@_);	161	my $headerReturn = $self->header(@_);
145	$returnValue = $headerReturn if defined $headerReturn;	162	$returnValue = $headerReturn if defined $headerReturn;
		163	# FIXME: we won't need noContent after reply_with_redirect() is adopted
146	return $returnValue if $r->header_only or $self->{noContent};	164	return $returnValue if $r->header_only or $self->{noContent};
147		165
		166	# FIXME: when $self->{sendFile} is no longer being set, remove this:
148	# if the sendFile flag is set, send the file and exit;	167	# if the sendFile flag is set, send the file and exit;
149	if ($self->{sendFile}) {	168	if ($self->{sendFile}) {
150	return $self->sendFile;	169	return $self->sendFile;
151	}	170	}
152		171
…		…
175	This mechanism is fragile and will probably be replaced by something else in the	194	This mechanism is fragile and will probably be replaced by something else in the
176	future.	195	future.
177		196
178	=cut	197	=cut
179		198
		199	# FIXME: when $self->{sendFile} is no longer being set, remove this method
180	sub sendFile {	200	sub sendFile {
181	my ($self) = @_;	201	my ($self) = @_;
182		202
183	my $file = $self->{sendFile}->{source};	203	my $file = $self->{sendFile}->{source};
184		204
…		…
206	my ($self) = @_;	226	my ($self) = @_;
207		227
208	return $self->{r};	228	return $self->{r};
209	}	229	}
210		230
		231	=item reply_with_file($type, $source, $name)
		232
		233	Enables file sending mode, causing go() to send the file specified by $source to
		234	the client after calling pre_header_initialize(). The content type sent is
		235	$type, and the suggested client-side file name is $name.
		236
		237	=cut
		238
		239	sub reply_with_file {
		240	my ($self, $type, $source, $name) = @_;
		241
		242	$self->{reply_with_file} = {
		243	type => $type,
		244	source => $source,
		245	name => $name,
		246	};
		247	}
		248
		249	=item do_reply_with_file($fileHash)
		250
		251	Handler for reply_with_file(), used by go(). DO NOT CALL THIS METHOD DIRECTLY.
		252
		253	=cut
		254
		255	sub do_reply_with_file {
		256	my ($self, $fileHash) = @_;
		257	my $r = $self->r;
		258
		259	my $type = $self->{sendFile}->{type};
		260	my $source = $fileHash->{source};
		261	my $name = $self->{sendFile}->{name};
		262
		263	# if there was a problem, we return here and let go() worry about sending the reply
		264	return NOT_FOUND unless -e $source;
		265	return FORBIDDEN unless -r $source;
		266
		267	# open the file now, so we can send the proper error status is we fail
		268	open my $fh, "<", $source or return SERVER_ERROR;
		269
		270	# send our custom HTTP header
		271	$r->status(OK);
		272	$r->content_type($type);
		273	$r->header_out("Content-Disposition" => "attachment; filename=\"$name\"");
		274	$r->send_http_header;
		275
		276	# send the file
		277	$r->send_fd($fh);
		278
		279	# close the file and go home
		280	close $fh;
		281	}
		282
		283	=item reply_with_redirect($url)
		284
		285	Enables redirect mode, causing go() to redirect to the given URL after calling
		286	pre_header_initialize().
		287
		288	=cut
		289
		290	sub reply_with_redirect {
		291	my ($self, $url) = @_;
		292
		293	$self->{reply_with_redirect} = $url;
		294	}
		295
		296	=item do_reply_with_redirect($url)
		297
		298	Handler for reply_with_redirect(), used by go(). DO NOT CALL THIS METHOD DIRECTLY.
		299
		300	=cut
		301
		302	sub do_reply_with_redirect {
		303	my ($self, $url) = @_;
		304	my $r = $self->r;
		305
		306	$r->status(REDIRECT);
		307	$r->header_out(Location => $url);
		308	$r->send_http_header();
		309	}
		310
211	=back	311	=back
212		312
213	=cut	313	=cut
214		314
215	################################################################################	315	################################################################################
…		…
253	=cut	353	=cut
254		354
255	sub header {	355	sub header {
256	my $self = shift;	356	my $self = shift;
257	my $r = $self->r;	357	my $r = $self->r;
		358
		359	# FIXME: when $self->{sendFile} is no longer being set, remove sendFile handler
258		360
259	if ($self->{sendFile}) {	361	if ($self->{sendFile}) {
260	my $contentType = $self->{sendFile}->{type};	362	my $contentType = $self->{sendFile}->{type};
261	my $fileName = $self->{sendFile}->{name};	363	my $fileName = $self->{sendFile}->{name};
262	$r->content_type($contentType);	364	$r->content_type($contentType);
…		…
479	my $courseID = $urlpath->arg("courseID");	581	my $courseID = $urlpath->arg("courseID");
480	my $userID = $r->param("user");	582	my $userID = $r->param("user");
481	my $eUserID = $r->param("effectiveUser");	583	my $eUserID = $r->param("effectiveUser");
482		584
483	my $stopActingURL = $self->systemLink($urlpath, # current path	585	my $stopActingURL = $self->systemLink($urlpath, # current path
484	values => {
485	effectiveUser => $userID,	586	params => { effectiveUser => $userID },
486	},
487	);	587	);
488	my $logoutURL = $self->systemLink($urlpath->newFromModule(__PACKAGE__ . "::Logout", courseID => $courseID));	588	my $logoutURL = $self->systemLink($urlpath->newFromModule(__PACKAGE__ . "::Logout", courseID => $courseID));
489		589
490	print "\n<!-- BEGIN " . __PACKAGE__ . "::loginstatus -->\n";	590	print "\n<!-- BEGIN " . __PACKAGE__ . "::loginstatus -->\n";
491		591
…		…
1053		1153
1054	=over	1154	=over
1055		1155
1056	=item params	1156	=item params
1057		1157
1058	A reference to a list containing names of parameters to add to the C<values>	1158	Can be either a reference to an array or a reference to a hash.
1059	hash below. The values are taken from the current request.
1060		1159
1061	=item values	1160	If it is a reference to a hash, it maps parmaeter names to values. These
		1161	parameters will be included in the generated link. If a value is an arrayref,
		1162	the values of the array referenced will be used. If a value is undefined, the
		1163	value from the current request will be used.
1062		1164
1063	A reference to a hash associating request parameters with replacement values.	1165	If C<params> is an arrayref, it is interpreted as a list of parameter names.
1064	Each parameter listed here is added to the URL.	1166	These parameters will be included in the generated link, using the values from
		1167	the current request.
1065		1168
1066	FIXME: this should be changed so that params is a hash, and a value is taken	1169	Unless C<authen> is false (see below), the authentication parameters (C<user>,
1067	from the current request if the value given is undef. The get rid of values. FIX	1170	C<effectiveUser>, and C<key>) are included with their default values.
1068	THIS SOON before too much code relies on it!
1069		1171
1070	=item authen	1172	=item authen
1071		1173
1072	If true, authentication parameters (C<user>, C<effectiveUser>, and <key>) will	1174	If set to a false value, the authentication parameters (C<user>,
1073	be included in the list of C<params>. Since this is usually what you want, if	1175	C<effectiveUser>, and C<key>) are included in the the generated link unless
1074	this option is not given a true value is assumed.	1176	explicitly listed in C<params>.
1075		1177
1076	=back	1178	=back
1077		1179
1078	=cut	1180	=cut
1079		1181
1080	# FIXME: there should probably be an option for prepending "http://hostname:port"	1182	# FIXME: there should probably be an option for prepending "http://hostname:port"
1081	sub systemLink {	1183	sub systemLink {
1082	my ($self, $urlpath, %options) = @_;	1184	my ($self, $urlpath, %options) = @_;
1083	my $r = $self->r;	1185	my $r = $self->r;
1084		1186
1085	my @params = ();	1187	my %params = ();
1086	if (exists $options{params}) {	1188	if (exists $options{params}) {
1087	croak "option 'params' is not an arrayref" unless ref $options{params} eq "ARRAY";	1189	if (ref $options{params} eq "HASH") {
1088	@params = @{ $options{params} };	1190	%params = %{ $options{params} };
		1191	} elsif (ref $options{params} eq "ARRAY") {
		1192	my @names = @{ $options{params} };
		1193	@params{@names} = ();
		1194	} else {
		1195	croak "option 'params' is not a hashref or an arrayref";
1089	}	1196	}
1090
1091	my %values = ();
1092	if (exists $options{values}) {
1093	croak "option 'values' is not an hashref" unless ref $options{values} eq "HASH";
1094	%values = %{ $options{values} };
1095	}	1197	}
1096		1198
1097	my $authen = exists $options{authen} ? $options{authen} : 1;	1199	my $authen = exists $options{authen} ? $options{authen} : 1;
1098	push @params, qw/user effectiveUser key/ if $authen;	1200	if ($authen) {
1099		1201	$params{user} = undef unless exists $params{user};
1100	foreach my $param (@params) {	1202	$params{effectiveUser} = undef unless exists $params{effectiveUser};
1101	next if exists $values{$param};	1203	$params{key} = undef unless exists $params{key};
1102	$values{$param} = $r->param($param);
1103	}	1204	}
1104		1205
1105	my $url = $r->location . $urlpath->path;	1206	my $url = $r->location . $urlpath->path;
		1207	my $first = 1;
1106		1208
		1209	foreach my $name (keys %params) {
		1210	my $value = $params{$name};
		1211
		1212	my @values;
		1213	if (defined $value) {
		1214	if (ref $value eq "ARRAY") {
		1215	@values = @$value;
		1216	} else {
		1217	@values = $value;
		1218	}
		1219	} elsif (defined $r->param($name)) {
		1220	@values = $r->param($name);
		1221	}
		1222
1107	if (keys %values) {	1223	if (@values) {
		1224	if ($first) {
1108	$url .= "?";	1225	$url .= "?";
1109	$url .= join("&", map { "$_=$values{$_}" } keys %values);	1226	$first = 0;
		1227	} else {
		1228	$url .= "&";
		1229	}
		1230	$url .= join "&", map { "$name=$_" } @values;
		1231	}
1110	}	1232	}
1111		1233
1112	return $url;	1234	return $url;
1113	}	1235	}
1114		1236

 Legend:



Removed from v.1910
 


changed lines


 
Added in v.1911
 Legend:



Removed from v.1910
 


changed lines


 
Added in v.1911
-Removed from v.1910
+Added in v.1911

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9