[system] / trunk / webwork2 / lib / WeBWorK / ContentGenerator.pm Repository:
ViewVC logotype

Annotation of /trunk/webwork2/lib/WeBWorK/ContentGenerator.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2014 - (view) (download) (as text)

1 : sh002i 455 ################################################################################
2 : sh002i 1663 # WeBWorK Online Homework Delivery System
3 :     # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
4 : toenail 2014 # $CVSHeader: webwork-modperl/lib/WeBWorK/ContentGenerator.pm,v 1.95 2004/05/06 20:21:48 toenail Exp $
5 : sh002i 1663 #
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
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.
10 :     #
11 :     # This program is distributed in the hope that it will be useful, but WITHOUT
12 :     # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
13 :     # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the
14 :     # Artistic License for more details.
15 : sh002i 455 ################################################################################
16 :    
17 : malsyned 313 package WeBWorK::ContentGenerator;
18 : malsyned 305
19 : sh002i 455 =head1 NAME
20 :    
21 :     WeBWorK::ContentGenerator - base class for modules that generate page content.
22 :    
23 : sh002i 1861 =head1 SYNOPSIS
24 :    
25 :     # start with a WeBWorK::Request object: $r
26 :    
27 :     use WeBWorK::ContentGenerator::SomeSubclass;
28 :    
29 :     my $cg = WeBWorK::ContentGenerator::SomeSubclass->new($r);
30 :     my $result = $cg->go();
31 :    
32 :     =head1 DESCRIPTION
33 :    
34 : sh002i 1873 WeBWorK::ContentGenerator provides the framework for generating page content.
35 :     "Content generators" are subclasses of this class which provide content for
36 :     particular parts of the system.
37 : sh002i 1861
38 : sh002i 1873 Default versions of methods used by the templating system are provided. Several
39 :     useful methods are provided for rendering common output idioms and some
40 :     miscellaneous utilities are provided.
41 :    
42 : sh002i 455 =cut
43 :    
44 : malsyned 441 use strict;
45 :     use warnings;
46 : sh002i 1911 use Apache::Constants qw(:response);
47 : sh002i 1882 use Carp;
48 : sh002i 1880 use CGI::Pretty qw(*ul *li);
49 : sh002i 469 use URI::Escape;
50 : sh002i 1869 use WeBWorK::Template qw(template);
51 : malsyned 390
52 : sh002i 1873 ################################################################################
53 : malsyned 390
54 : sh002i 1861 =head1 CONSTRUCTOR
55 : sh002i 1838
56 : sh002i 1861 =over
57 :    
58 :     =item new($r)
59 :    
60 : sh002i 1873 Creates a new instance of a content generator. Supply a WeBWorK::Request object
61 : sh002i 1861 $r.
62 :    
63 :     =cut
64 :    
65 : sh002i 1613 sub new {
66 : sh002i 1838 my ($invocant, $r) = @_;
67 : malsyned 323 my $class = ref($invocant) || $invocant;
68 : sh002i 809 my $self = {
69 : sh002i 1838 r => $r, # this is now a WeBWorK::Request
70 :     ce => $r->ce(), # these three are here for
71 :     db => $r->db(), # backward-compatability
72 :     authz => $r->authz(), # with unconverted CGs
73 : sh002i 1869 noContent => undef, # this should get clobbered at some point
74 : sh002i 809 };
75 : malsyned 305 bless $self, $class;
76 :     return $self;
77 :     }
78 :    
79 : sh002i 1861 =back
80 :    
81 :     =cut
82 :    
83 : sh002i 469 ################################################################################
84 : malsyned 323
85 : sh002i 1861 =head1 INVOCATION
86 :    
87 :     =over
88 :    
89 :     =item go()
90 :    
91 : sh002i 1873 Generates a page, using methods from the particular subclass of ContentGenerator
92 :     that is instantiated. Generatoion is broken up into several steps, to give
93 :     subclasses ample control over the process.
94 : sh002i 1861
95 :     =over
96 :    
97 : sh002i 1873 =item 1
98 : sh002i 1861
99 : sh002i 1873 go() will attempt to call the method pre_header_initialize(). This method may be
100 :     implemented in subclasses which must do processing before the HTTP header is
101 :     emitted.
102 : sh002i 1861
103 : sh002i 1873 =item 2
104 : sh002i 1861
105 : sh002i 1873 go() will attempt to call the method header(). This method emits the HTTP
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
108 :     return value of header() will be used as the result of this function, if it is
109 :     defined.
110 : sh002i 1861
111 : sh002i 1911 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 :    
115 : sh002i 1873 =item 3
116 : sh002i 1861
117 : sh002i 1873 At this point, go() will terminate if the request is a HEAD request or if the
118 :     field $self->{noContent} contains a true value.
119 : sh002i 1861
120 : sh002i 1911 FIXME: I don't think we'll need noContent after reply_with_redirect() is
121 :     adopted by all modules.
122 :    
123 : sh002i 1873 =item 4
124 : sh002i 1861
125 : sh002i 1873 If the field $self->{sendFile} is defined, the method sendFile() is called to
126 :     send the specified file to the client, and go() terminates. See below.
127 : sh002i 1861
128 : sh002i 1873 =item 5
129 : sh002i 1861
130 : sh002i 1873 go() then attempts to call the method initialize(). This method may be
131 :     implemented in subclasses which must do processing after the HTTP header is sent
132 :     but before any content is sent.
133 : sh002i 1861
134 : sh002i 1873 =item 6
135 :    
136 :     The method content() is called to send the page content to client.
137 :    
138 : sh002i 1861 =back
139 :    
140 :     =cut
141 :    
142 : sh002i 469 sub go {
143 : sh002i 1873 my ($self) = @_;
144 :     my $r = $self->r;
145 : sh002i 1869 my $ce = $r->ce;
146 :    
147 : malsyned 1408 my $returnValue = OK;
148 : sh002i 1131
149 : sh002i 469 $self->pre_header_initialize(@_) if $self->can("pre_header_initialize");
150 : sh002i 1873
151 : sh002i 1911 # 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 :    
161 : malsyned 1408 my $headerReturn = $self->header(@_);
162 :     $returnValue = $headerReturn if defined $headerReturn;
163 : sh002i 1911 # FIXME: we won't need noContent after reply_with_redirect() is adopted
164 : malsyned 1408 return $returnValue if $r->header_only or $self->{noContent};
165 : malsyned 313
166 : sh002i 1911 # FIXME: when $self->{sendFile} is no longer being set, remove this:
167 : sh002i 1613 # if the sendFile flag is set, send the file and exit;
168 :     if ($self->{sendFile}) {
169 :     return $self->sendFile;
170 :     }
171 :    
172 : sh002i 1873 $self->initialize() if $self->can("initialize");
173 : sh002i 1225
174 : sh002i 1873 $self->content();
175 : malsyned 1408
176 :     return $returnValue;
177 : sh002i 469 }
178 :    
179 : sh002i 1861 =item sendFile()
180 :    
181 : sh002i 1873 Sends the file specified in $self->{sendFile} to the client. $self->{sendFile}
182 :     should be a reference to a hash containing the following fields:
183 :    
184 :     source => full path to the file to send
185 :     type => the content type of the file
186 :     name => the name that the client should give to the file upon download
187 :    
188 :     This method is called internally by go() if the field $self->{sendFile} is
189 :     present.
190 :    
191 :     This mechanism relies on the header() method to send appropriate C<Content-Type>
192 :     and C<Content-Disposition> headers.
193 :    
194 :     This mechanism is fragile and will probably be replaced by something else in the
195 :     future.
196 :    
197 : sh002i 1861 =cut
198 :    
199 : sh002i 1911 # FIXME: when $self->{sendFile} is no longer being set, remove this method
200 : sh002i 1613 sub sendFile {
201 :     my ($self) = @_;
202 :    
203 :     my $file = $self->{sendFile}->{source};
204 :    
205 :     return NOT_FOUND unless -e $file;
206 :     return FORBIDDEN unless -r $file;
207 :    
208 :     open my $fh, "<", $file
209 :     or return SERVER_ERROR;
210 :     while (<$fh>) {
211 :     print $_;
212 :     }
213 :     close $fh;
214 :    
215 :     return OK;
216 :     }
217 :    
218 : sh002i 1873 =item r()
219 : sh002i 1861
220 : sh002i 1873 Returns a reference to the WeBWorK::Request object associated with this
221 :     instance.
222 : sh002i 1861
223 :     =cut
224 :    
225 : sh002i 1873 sub r {
226 :     my ($self) = @_;
227 : sh002i 1869
228 : sh002i 1873 return $self->{r};
229 : sh002i 469 }
230 :    
231 : sh002i 1984 =item reply_with_file($type, $source, $name, $delete_after)
232 : sh002i 1911
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 : sh002i 1984 $type, and the suggested client-side file name is $name. If $delete_after is
236 :     true, $source is deleted after it is sent.
237 : sh002i 1911
238 :     =cut
239 :    
240 :     sub reply_with_file {
241 : sh002i 1984 my ($self, $type, $source, $name, $delete_after) = @_;
242 :     $delete_after ||= "";
243 : sh002i 1911
244 :     $self->{reply_with_file} = {
245 :     type => $type,
246 :     source => $source,
247 :     name => $name,
248 : sh002i 1984 delete_after => $delete_after,
249 : sh002i 1911 };
250 :     }
251 :    
252 :     =item do_reply_with_file($fileHash)
253 :    
254 :     Handler for reply_with_file(), used by go(). DO NOT CALL THIS METHOD DIRECTLY.
255 :    
256 :     =cut
257 :    
258 :     sub do_reply_with_file {
259 :     my ($self, $fileHash) = @_;
260 :     my $r = $self->r;
261 :    
262 : sh002i 1984 my $type = $fileHash->{type};
263 : sh002i 1911 my $source = $fileHash->{source};
264 : sh002i 1984 my $name = $fileHash->{name};
265 :     my $delete_after = $fileHash->{delete_after};
266 : sh002i 1911
267 :     # if there was a problem, we return here and let go() worry about sending the reply
268 :     return NOT_FOUND unless -e $source;
269 :     return FORBIDDEN unless -r $source;
270 :    
271 :     # open the file now, so we can send the proper error status is we fail
272 :     open my $fh, "<", $source or return SERVER_ERROR;
273 :    
274 :     # send our custom HTTP header
275 :     $r->status(OK);
276 :     $r->content_type($type);
277 :     $r->header_out("Content-Disposition" => "attachment; filename=\"$name\"");
278 :     $r->send_http_header;
279 :    
280 :     # send the file
281 :     $r->send_fd($fh);
282 :    
283 :     # close the file and go home
284 :     close $fh;
285 : sh002i 1984
286 :     if ($delete_after) {
287 :     unlink $source or warn "failed to unlink $source after sending: $!";
288 :     }
289 : sh002i 1911 }
290 :    
291 :     =item reply_with_redirect($url)
292 :    
293 :     Enables redirect mode, causing go() to redirect to the given URL after calling
294 :     pre_header_initialize().
295 :    
296 :     =cut
297 :    
298 :     sub reply_with_redirect {
299 :     my ($self, $url) = @_;
300 :    
301 :     $self->{reply_with_redirect} = $url;
302 :     }
303 :    
304 :     =item do_reply_with_redirect($url)
305 :    
306 :     Handler for reply_with_redirect(), used by go(). DO NOT CALL THIS METHOD DIRECTLY.
307 :    
308 :     =cut
309 :    
310 :     sub do_reply_with_redirect {
311 :     my ($self, $url) = @_;
312 :     my $r = $self->r;
313 :    
314 :     $r->status(REDIRECT);
315 :     $r->header_out(Location => $url);
316 :     $r->send_http_header();
317 :     }
318 :    
319 : sh002i 1873 =back
320 : sh002i 1861
321 :     =cut
322 :    
323 : sh002i 1873 ################################################################################
324 : sh002i 469
325 : sh002i 1873 =head1 STANDARD METHODS
326 : sh002i 1861
327 : sh002i 1873 The following are the standard content generator methods. Some are defined here,
328 :     but may be overridden in a subclass. Others are not defined unless they are
329 :     defined in a subclass.
330 : sh002i 1861
331 : sh002i 1873 =over
332 : sh002i 469
333 : sh002i 1873 =item pre_header_initialize()
334 : sh002i 1861
335 : sh002i 1873 Not defined in this package.
336 : sh002i 1861
337 : sh002i 1873 May be defined by a subclass to perform any processing that must occur before
338 :     the HTTP header is sent.
339 :    
340 : sh002i 1861 =cut
341 :    
342 : sh002i 1873 #sub pre_header_initialize { }
343 : malsyned 323
344 : sh002i 1873 =item header()
345 : sh002i 1861
346 : sh002i 1873 Defined in this package.
347 : sh002i 1861
348 : sh002i 1873 Generates and sends a default HTTP header. If the field $self->{sendFile} is
349 :     present, sends the following headers (where TYPE is $self->{sendFile}->{type}
350 :     and NAME is $self->{sendFile}->{name}):
351 : sh002i 1861
352 : sh002i 1873 Content-Type: TYPE
353 :     Content-Disposition: attachment; filename=NAME
354 : sh002i 425
355 : sh002i 1873 If $self->{sendFile} is not present, sends the following headers:
356 : sh002i 1861
357 : sh002i 1873 Content-Type: text/html
358 : sh002i 1861
359 : sh002i 1873 See sendFile() above for more information on the sendFile mechanism.
360 :    
361 : sh002i 1861 =cut
362 :    
363 : sh002i 1873 sub header {
364 : sh002i 425 my $self = shift;
365 : sh002i 1873 my $r = $self->r;
366 : sh002i 425
367 : sh002i 1911 # FIXME: when $self->{sendFile} is no longer being set, remove sendFile handler
368 :    
369 : sh002i 1873 if ($self->{sendFile}) {
370 :     my $contentType = $self->{sendFile}->{type};
371 :     my $fileName = $self->{sendFile}->{name};
372 :     $r->content_type($contentType);
373 :     $r->header_out("Content-Disposition" => "attachment; filename=\"$fileName\"");
374 :     } else {
375 :     $r->content_type("text/html");
376 :    
377 : sh002i 425 }
378 : sh002i 469
379 : sh002i 1873 $r->send_http_header();
380 :     return OK;
381 : sh002i 425 }
382 :    
383 : sh002i 1873 =item initialize()
384 : sh002i 1861
385 : sh002i 1873 Not defined in this package.
386 : sh002i 1861
387 : sh002i 1873 May be defined by a subclass to perform any processing that must occur after the
388 :     HTTP header is sent but before any content is sent.
389 : sh002i 1861
390 :     =cut
391 :    
392 : sh002i 1873 #sub initialize { }
393 : sh002i 1861
394 : sh002i 1873 =item content()
395 : sh002i 1861
396 : sh002i 1873 Defined in this package.
397 : sh002i 1861
398 : sh002i 1873 Print the content of the generated page.
399 : sh002i 1861
400 : sh002i 1873 The implementation in this package uses WeBWorK::Template to define the content
401 :     of the page. See WeBWorK::Template for details.
402 : malsyned 390
403 : sh002i 1873 If a method named templateName() exists, it it called to determine the name of
404 :     the template to use. If not, the default template, "system", is used. The
405 :     location of the template is looked up in the course environment.
406 : sh002i 1861
407 :     =cut
408 :    
409 : sh002i 1873 sub content {
410 :     my ($self) = @_;
411 :     my $ce = $self->r->ce;
412 : sh002i 737
413 : sh002i 1873 # if the content generator specifies a custom template name, use that
414 :     # field in the $ce->{templates} hash instead of "system" if it exists.
415 :     my $templateName;
416 :     if ($self->can("templateName")) {
417 :     $templateName = $self->templateName;
418 :     } else {
419 :     $templateName = "system";
420 :     }
421 :     $templateName = "system" unless exists $ce->{templates}->{$templateName};
422 :     template($ce->{templates}->{$templateName}, $self);
423 : sh002i 737 }
424 :    
425 : sh002i 1861 =back
426 :    
427 :     =cut
428 :    
429 : sh002i 1873 # ------------------------------------------------------------------------------
430 : sh002i 1866
431 : sh002i 1873 =head2 Template escape handlers
432 : sh002i 1866
433 : sh002i 1873 Template escape handlers are invoked when the template processor encounters a
434 :     matching escape sequence in the template. The escapse sequence's arguments are
435 :     passed to the methods as a reference to a hash.
436 : sh002i 1866
437 : sh002i 1873 For more information, refer to WeBWorK::Template.
438 : malsyned 390
439 : sh002i 1873 The following template escapes handlers are defined here or may be defined in
440 :     subclasses. For methods that are not defined in this package, the documentation
441 :     defines the interface and behavior that any subclass implementation must follow.
442 : malsyned 313
443 : sh002i 1861 =over
444 :    
445 : sh002i 1873 =item head()
446 : sh002i 1861
447 : sh002i 1873 Not defined in this package.
448 : sh002i 1861
449 : sh002i 1873 Any tags that should appear in the HEAD of the document.
450 : sh002i 1861
451 :     =cut
452 :    
453 : sh002i 1873 #sub head { }
454 : malsyned 349
455 : sh002i 1873 =item info()
456 : sh002i 682
457 : sh002i 1873 Not defined in this package.
458 : sh002i 1861
459 : sh002i 1873 Auxiliary information related to the content displayed in the C<body>.
460 : sh002i 1861
461 : sh002i 1873 =cut
462 : sh002i 1861
463 : sh002i 1873 #sub info { }
464 : sh002i 1861
465 : sh002i 1873 =item links()
466 : sh002i 1861
467 : sh002i 1873 Defined in this package.
468 : sh002i 1861
469 : sh002i 1873 Links that should appear on every page.
470 : sh002i 1861
471 :     =cut
472 :    
473 : sh002i 1866 sub links {
474 :     my ($self) = @_;
475 : sh002i 1873 my $r = $self->r;
476 : sh002i 1866 my $db = $r->db;
477 :     my $urlpath = $r->urlpath;
478 :    
479 :     # we're linking to other places in the same course, so grab the courseID from the current path
480 :     my $courseID = $urlpath->arg("courseID");
481 :    
482 :     # to make things more concise
483 :     my %args = ( courseID => $courseID );
484 :     my $pfx = "WeBWorK::ContentGenerator::";
485 :    
486 : sh002i 1880 my $sets = $urlpath->newFromModule("${pfx}ProblemSets", %args);
487 :     my $options = $urlpath->newFromModule("${pfx}Options", %args);
488 :     my $grades = $urlpath->newFromModule("${pfx}Grades", %args);
489 :     my $logout = $urlpath->newFromModule("${pfx}Logout", %args);
490 :    
491 :     print "\n<!-- BEGIN " . __PACKAGE__ . "::links -->\n";
492 :     print CGI::start_ul({class=>"LinksMenu"});
493 :     print CGI::li(CGI::span({style=>"font-size:larger"},
494 :     CGI::a({href=>$self->systemLink($sets)}, "Problem Sets")));
495 :     print CGI::li(CGI::a({href=>$self->systemLink($options)}, $options->name));
496 :     print CGI::li(CGI::a({href=>$self->systemLink($grades)}, $grades->name));
497 :     print CGI::li(CGI::a({href=>$self->systemLink($logout)}, $logout->name));
498 :    
499 : sh002i 1866 my $PermissionLevel = $db->getPermissionLevel($r->param("user")); # checked
500 :     my $permLevel = $PermissionLevel ? $PermissionLevel->permission : 0;
501 :    
502 :     if ($permLevel > 0) {
503 :     my $ipfx = "${pfx}Instructor::";
504 :    
505 :     my $userID = $r->param("effectiveUser");
506 :     my $setID = $urlpath->arg("setID");
507 : toenail 2014 $setID = "" if (defined $setID && !(grep /$setID/, $db->listUserSets($userID)));
508 : sh002i 1866 my $problemID = $urlpath->arg("problemID");
509 : toenail 2014 $problemID = "" if (defined $problemID && !(grep /$problemID/, $db->listUserProblems($userID, $setID)));
510 : sh002i 1866
511 :     my $instr = $urlpath->newFromModule("${ipfx}Index", %args);
512 : sh002i 1918 my $addUsers = $urlpath->newFromModule("${ipfx}AddUsers", %args);
513 : sh002i 1866 my $userList = $urlpath->newFromModule("${ipfx}UserList", %args);
514 :    
515 :     # set list links
516 :     my $setList = $urlpath->newFromModule("${ipfx}ProblemSetList", %args);
517 :     my $setDetail = $urlpath->newFromModule("${ipfx}ProblemSetEditor", %args, setID => $setID);
518 :     my $problemEditor = $urlpath->newFromModule("${ipfx}PGProblemEditor", %args, setID => $setID, problemID => $problemID);
519 :    
520 : jj 1998 my $maker = $urlpath->newFromModule("${ipfx}SetMaker", %args);
521 : sh002i 1918 my $assigner = $urlpath->newFromModule("${ipfx}Assigner", %args);
522 : sh002i 1866 my $mail = $urlpath->newFromModule("${ipfx}SendMail", %args);
523 :     my $scoring = $urlpath->newFromModule("${ipfx}Scoring", %args);
524 :    
525 :     # statistics links
526 :     my $stats = $urlpath->newFromModule("${ipfx}Stats", %args);
527 :     my $userStats = $urlpath->newFromModule("${ipfx}Stats", %args, statType => "student", userID => $userID);
528 :     my $setStats = $urlpath->newFromModule("${ipfx}Stats", %args, statType => "set", setID => $setID);
529 :    
530 :     my $files = $urlpath->newFromModule("${ipfx}FileXfer", %args);
531 :    
532 : jj 1998 print CGI::hr();
533 : sh002i 1880 print CGI::start_li();
534 :     print CGI::span({style=>"font-size:larger"}, CGI::a({href=>$self->systemLink($instr)}, $instr->name));
535 :     print CGI::start_ul();
536 : sh002i 1918 print CGI::li(CGI::a({href=>$self->systemLink($addUsers)}, $addUsers->name));
537 : sh002i 1880 print CGI::li(CGI::a({href=>$self->systemLink($userList)}, $userList->name));
538 :     print CGI::start_li();
539 :     print CGI::a({href=>$self->systemLink($setList)}, $setList->name);
540 : sh002i 1869 if (defined $setID and $setID ne "") {
541 : sh002i 1880 print CGI::start_ul();
542 :     print CGI::start_li();
543 :     print CGI::a({href=>$self->systemLink($setDetail)}, $setID);
544 : sh002i 1869 if (defined $problemID and $problemID ne "") {
545 : sh002i 1880 print CGI::ul(
546 : sh002i 1866 CGI::li(CGI::a({href=>$self->systemLink($problemEditor)}, $problemID))
547 :     );
548 :     }
549 : sh002i 1880 print CGI::end_li();
550 :     print CGI::end_ul();
551 : sh002i 1866 }
552 : sh002i 1880 print CGI::end_li();
553 : jj 1998 print CGI::li(CGI::a({href=>$self->systemLink($maker)}, $maker->name));
554 : sh002i 1918 print CGI::li(CGI::a({href=>$self->systemLink($assigner)}, $assigner->name));
555 : sh002i 1880 print CGI::li(CGI::a({href=>$self->systemLink($mail)}, $mail->name));
556 :     print CGI::li(CGI::a({href=>$self->systemLink($scoring)}, $scoring->name));
557 :     print CGI::start_li();
558 :     print CGI::a({href=>$self->systemLink($stats)}, $stats->name);
559 : sh002i 1869 if (defined $userID and $userID ne "") {
560 : sh002i 1880 print CGI::ul(
561 : sh002i 1866 CGI::li(CGI::a({href=>$self->systemLink($userStats)}, $userID))
562 :     );
563 :     }
564 : sh002i 1869 if (defined $setID and $setID ne "") {
565 : sh002i 1880 print CGI::ul(
566 : sh002i 1866 CGI::li(CGI::a({href=>$self->systemLink($setStats)}, $setID))
567 :     );
568 :     }
569 : sh002i 1880 print CGI::end_li();
570 :     print CGI::li(CGI::a({href=>$self->systemLink($files)}, $files->name));
571 :     print CGI::end_ul();
572 :     print CGI::end_li();
573 : sh002i 1866 }
574 :    
575 : sh002i 1880 print CGI::end_ul();
576 :     print "<!-- end " . __PACKAGE__ . "::links -->\n";
577 : sh002i 1866
578 : sh002i 1880 return "";
579 : sh002i 1866 }
580 :    
581 : sh002i 1873 =item loginstatus()
582 : sh002i 1861
583 : sh002i 1873 Defined in this package.
584 : sh002i 1861
585 : sh002i 1873 Print a notification message announcing the current real user and effective
586 :     user, a link to stop acting as the effective user, and a link to logout.
587 : sh002i 1861
588 :     =cut
589 :    
590 :     sub loginstatus {
591 : sh002i 1869 my ($self) = @_;
592 : sh002i 1873 my $r = $self->r;
593 : sh002i 1869 my $urlpath = $r->urlpath;
594 : sh002i 1861
595 :     my $key = $r->param("key");
596 :    
597 : sh002i 1869 if ($key) {
598 :     my $courseID = $urlpath->arg("courseID");
599 :     my $userID = $r->param("user");
600 :     my $eUserID = $r->param("effectiveUser");
601 :    
602 : sh002i 1882 my $stopActingURL = $self->systemLink($urlpath, # current path
603 : sh002i 1911 params => { effectiveUser => $userID },
604 : sh002i 1882 );
605 : sh002i 1869 my $logoutURL = $self->systemLink($urlpath->newFromModule(__PACKAGE__ . "::Logout", courseID => $courseID));
606 :    
607 : sh002i 1880 print "\n<!-- BEGIN " . __PACKAGE__ . "::loginstatus -->\n";
608 :    
609 : sh002i 1869 print "Logged in as $userID. ";
610 :     print CGI::a({href=>$logoutURL}, "Log Out");
611 :    
612 :     if ($eUserID ne $userID) {
613 :     print " | Acting as $eUserID. ";
614 :     print CGI::a({href=>$stopActingURL}, "Stop Acting");
615 :     }
616 : sh002i 1880
617 :     print "<!-- END " . __PACKAGE__ . "::loginstatus -->\n";
618 : sh002i 1861 }
619 :    
620 :     return "";
621 :     }
622 :    
623 : sh002i 1873 =item nav($args)
624 : sh002i 1869
625 : sh002i 1873 Not defined in this package.
626 : sh002i 1861
627 : sh002i 1873 Links to the previous, next, and parent objects.
628 : sh002i 1861
629 : sh002i 1873 $args is a reference to a hash containing the following fields:
630 :    
631 : sh002i 1861 style => text|image
632 :     imageprefix => prefix to prepend to base image URL
633 :     imagesuffix => suffix to append to base image URL
634 :     separator => HTML to place in between links
635 :    
636 : sh002i 1873 If C<style> is "image", image URLs are constructed by prepending C<imageprefix>
637 :     and postpending C<imagesuffix> to the image base names defined by the
638 :     implementor. (Examples of base names include "Prev", "Next", "ProbSet", and
639 :     "Up"). Each concatenated string should form an absolute URL to an image file.
640 :     For example:
641 : sh002i 1861
642 : sh002i 1873 <!--#nav style="images" imageprefix="/webwork2_files/images/nav"
643 :     imagesuffix=".gif" separator=" "-->
644 : sh002i 1861
645 : sh002i 1873 =cut
646 : sh002i 1861
647 : sh002i 1873 #sub nav { }
648 : sh002i 1861
649 : sh002i 1873 =item options()
650 :    
651 :     Not defined in this package.
652 :    
653 :     Print an auxiliary options form, related to the content displayed in the
654 :     C<body>.
655 :    
656 :     =item path($args)
657 :    
658 :     Defined in this package.
659 :    
660 :     Print "breadcrubs" from the root of the virtual hierarchy to the current page.
661 :     $args is a reference to a hash containing the following fields:
662 :    
663 : sh002i 1861 style => type of separator: text|image
664 : sh002i 1873 image => if style=image, URL of image to use as path separator
665 :     text => if style=text, text to use as path separator
666 :     if style=image, the ALT text of each separator image
667 :     textonly => suppress all HTML, return only plain text
668 : sh002i 1861
669 : sh002i 1873 The implementation in this package takes information from the WeBWorK::URLPath
670 :     associated with the current request.
671 :    
672 : sh002i 1861 =cut
673 :    
674 :     sub path {
675 :     my ($self, $args) = @_;
676 : sh002i 1873 my $r = $self->r;
677 : sh002i 1861
678 :     my @path;
679 :    
680 :     my $urlpath = $r->urlpath;
681 :     do {
682 :     unshift @path, $urlpath->name, $r->location . $urlpath->path;
683 :     } while ($urlpath = $urlpath->parent);
684 :    
685 :     $path[$#path] = ""; # we don't want the last path element to be a link
686 :    
687 : sh002i 1882 #print "\n<!-- BEGIN " . __PACKAGE__ . "::path -->\n";
688 : sh002i 1880 print $self->pathMacro($args, @path);
689 : sh002i 1882 #print "<!-- END " . __PACKAGE__ . "::path -->\n";
690 : sh002i 1880
691 :     return "";
692 : sh002i 1861 }
693 :    
694 : sh002i 1873 =item siblings()
695 : sh002i 1861
696 : sh002i 1873 Not defined in this package.
697 : sh002i 1861
698 : sh002i 1873 Print links to siblings of the current object.
699 : sh002i 1861
700 : sh002i 1873 =cut
701 : sh002i 1861
702 : sh002i 1873 #sub siblings { }
703 :    
704 : jj 1942 =item timestamp()
705 :    
706 :     Defined in this package.
707 :    
708 :     Display the current time and date using default format "3:37pm on Jan 7, 2004".
709 :     The display format can be adjusted by giving a style in the template.
710 :     For example,
711 :    
712 :     <!--#timestamp style="%m/%d/%y at %I:%M%P"-->
713 :    
714 :     will give standard WeBWorK time format. Wording and other formatting
715 :     can be done in the template itself.
716 :     =cut
717 :    
718 :     sub timestamp {
719 :     my ($self, $args) = @_;
720 :     my $formatstring = "%l:%M%P on %b %e, %Y";
721 :     $formatstring = $args->{style} if(defined($args->{style}));
722 :     return(Date::Format::time2str($formatstring, time()));
723 :     }
724 :    
725 : sh002i 1873 =item submiterror()
726 :    
727 :     Defined in this package.
728 :    
729 :     Print any error messages resulting from the last form submission.
730 :    
731 : toenail 2013 This method is deprecated -- use message() instead
732 :    
733 : sh002i 1873 The implementation in this package prints the value of the field
734 :     $self->{submitError}, if it is present.
735 :    
736 : sh002i 1861 =cut
737 :    
738 :     sub submiterror {
739 :     my ($self) = @_;
740 : sh002i 1880
741 :     print "\n<!-- BEGIN " . __PACKAGE__ . "::submiterror -->\n";
742 :     print $self->{submitError} if exists $self->{submitError};
743 :     print "<!-- END " . __PACKAGE__ . "::submiterror -->\n";
744 :    
745 :     return "";
746 : sh002i 1861 }
747 :    
748 : toenail 2013 =item message()
749 :    
750 :     Defined in this package.
751 :    
752 :     Print any messages (error or non-error) resulting from the last form submission.
753 :     This could be used to give Sucess and Failure messages after an action is performed by a module.
754 :    
755 :     The implementation in this package prints the value of the field
756 :     $self->{message}, if it is present.
757 :    
758 :     =cut
759 :    
760 :     sub message {
761 :     my ($self) = @_;
762 :    
763 :     print "\n<!-- BEGIN " . __PACKAGE__ . "::message -->\n";
764 :     print $self->{message} if exists $self->{message};
765 :     print "<!-- END " . __PACKAGE__ . "::message -->\n";
766 :    
767 :     return "";
768 :     }
769 :    
770 :     =item addmessage($message)
771 :    
772 :     Defined in this package.
773 :    
774 :     Concatenates a new message to any previous ones.
775 :     This is preferred over any direct access to $self->{message} to avoid overwriting any
776 :     previously submitted messages
777 :    
778 :     The implementation in this package concatenates the given message to the end of the
779 :     current value of the field $self->{message} or sets $self->{message} if it is empty
780 :    
781 :     =cut
782 :    
783 :     sub addmessage {
784 :     my ($self, $message) = @_;
785 :    
786 :     $self->{message} .= $message;
787 :    
788 :     return "";
789 :     }
790 :    
791 :    
792 : sh002i 1873 =item title()
793 : sh002i 1861
794 : sh002i 1873 Defined in this package.
795 : sh002i 1861
796 : sh002i 1873 Print the title of the current page.
797 :    
798 :     The implementation in this package takes information from the WeBWorK::URLPath
799 :     associated with the current request.
800 :    
801 : sh002i 1861 =cut
802 :    
803 :     sub title {
804 :     my ($self, $args) = @_;
805 : sh002i 1873 my $r = $self->r;
806 : sh002i 1861
807 : sh002i 1880
808 : sh002i 1882 #print "\n<!-- BEGIN " . __PACKAGE__ . "::title -->\n";
809 : sh002i 1880 print $r->urlpath->name;
810 : sh002i 1882 #print "<!-- END " . __PACKAGE__ . "::title -->\n";
811 : sh002i 1880
812 :     return "";
813 : sh002i 1861 }
814 :    
815 : sh002i 1873 =item warnings()
816 : sh002i 1861
817 : sh002i 1873 Defined in this package.
818 : sh002i 1861
819 : sh002i 1873 Print accumulated warnings.
820 :    
821 :     The implementation in this package checks for a note in the request named
822 :     "warnings". If present, its contents are formatted and returned.
823 :    
824 : sh002i 1861 =cut
825 :    
826 :     sub warnings {
827 :     my ($self) = @_;
828 : sh002i 1873 my $r = $self->r;
829 : sh002i 1880
830 :     print "\n<!-- BEGIN " . __PACKAGE__ . "::warnings -->\n";
831 :     print $self->warningOutput($r->notes("warnings")) if $r->notes("warnings");
832 :     print "<!-- END " . __PACKAGE__ . "::warnings -->\n";
833 :    
834 :     return "";
835 : sh002i 1861 }
836 :    
837 :     =back
838 :    
839 : sh002i 1873 =cut
840 : sh002i 1861
841 : sh002i 1873 # ------------------------------------------------------------------------------
842 : sh002i 1861
843 : sh002i 1873 =head2 Conditional predicates
844 :    
845 :     Conditional predicate methods are invoked when the C<#if> escape sequence is
846 :     encountered in the template. If a method named C<if_predicate> is defined in
847 :     here or in the instantiated subclass, it is invoked.
848 :    
849 : sh002i 1861 The following predicates are currently defined:
850 :    
851 :     =over
852 :    
853 : sh002i 1873 =item if_can($function)
854 : sh002i 1861
855 : sh002i 1873 If a function named $function is present in the current content generator (or
856 :     any superclass), a true value is returned. Otherwise, a false value is returned.
857 : sh002i 1861
858 : sh002i 1873 The implementation in this package uses the method UNIVERSAL->can(function) to
859 :     arrive at the result.
860 :    
861 :     A subclass could redefine this method to, for example, "hide" a method from the
862 :     template:
863 :    
864 :     sub if_can {
865 :     my ($self, $arg) = @_;
866 :    
867 :     if ($arg eq "floobar") {
868 :     return 0;
869 :     } else {
870 :     return $self->SUPER::if_can($arg);
871 :     }
872 :     }
873 :    
874 : sh002i 1861 =cut
875 :    
876 : sh002i 1873 sub if_can {
877 :     my ($self, $arg) = @_;
878 : malsyned 525
879 : sh002i 1873 return $self->can($arg) ? 1 : 0;
880 : malsyned 525 }
881 :    
882 : sh002i 1873 =item if_loggedin($arg)
883 : sh002i 1861
884 : sh002i 1873 If the user is currently logged in, $arg is returned. Otherwise, the inverse of
885 :     $arg is returned.
886 : sh002i 1861
887 : sh002i 1873 The implementation in this package always returns $arg, since most content
888 :     generators are only reachable when the user is authenticated. It is up to
889 :     classes that can be reached without logging in to override this method and
890 :     provide the correct behavior.
891 :    
892 :     This is suboptimal, and may change in the future.
893 :    
894 : sh002i 1861 =cut
895 :    
896 : sh002i 1873 sub if_loggedin {
897 :     my ($self, $arg) = @_;
898 : malsyned 748
899 :     return $arg;
900 :     }
901 :    
902 : sh002i 1873 =item if_submiterror($arg)
903 : sh002i 1131
904 : sh002i 1873 If the last form submission generated an error, $arg is returned. Otherwise, the
905 :     inverse of $arg is returned.
906 :    
907 :     The implementation in this package checks for the field $self->{submitError} to
908 :     determine if an error condition is present.
909 :    
910 :     If a subclass uses some other method to classify submission results, this method could be
911 :     redefined to handle that variance:
912 :    
913 :     sub if_submiterror {
914 :     my ($self, $arg) = @_;
915 :    
916 :     my $status = $self->{processReturnValue};
917 :     if ($status != 0) {
918 :     return $arg;
919 :     } else {
920 :     return !$arg;
921 :     }
922 :     }
923 :    
924 : sh002i 1861 =cut
925 :    
926 : sh002i 1873 sub if_submiterror {
927 : malsyned 1017 my ($self, $arg) = @_;
928 : sh002i 1873
929 : malsyned 1017 if (exists $self->{submitError}) {
930 :     return $arg;
931 :     } else {
932 :     return !$arg;
933 :     }
934 :     }
935 :    
936 : toenail 2013 =item if_message($arg)
937 :    
938 :     If the last form submission generated a message, $arg is returned. Otherwise, the
939 :     inverse of $arg is returned.
940 :    
941 :     The implementation in this package checks for the field $self->{message} to
942 :     determine if a message is present.
943 :    
944 :     If a subclass uses some other method to classify submission results, this method could be
945 :     redefined to handle that variance:
946 :    
947 :     sub if_message {
948 :     my ($self, $arg) = @_;
949 :    
950 :     my $status = $self->{processReturnValue};
951 :     if ($status != 0) {
952 :     return $arg;
953 :     } else {
954 :     return !$arg;
955 :     }
956 :     }
957 :    
958 :     =cut
959 :    
960 :     sub if_message {
961 :     my ($self, $arg) = @_;
962 :    
963 :     if (exists $self->{message}) {
964 :     return $arg;
965 :     } else {
966 :     return !$arg;
967 :     }
968 :     }
969 :    
970 : sh002i 1861 =item if_warnings
971 : sh002i 1131
972 : sh002i 1873 If warnings have been emitted while handling this request, $arg is returned.
973 :     Otherwise, the inverse of $arg is returned.
974 :    
975 :     The implementation in this package checks for a note in the request named
976 :     "warnings". This is set by the WARN handler in Apache::WeBWorK when a warning is
977 :     handled.
978 :    
979 : sh002i 1869 =cut
980 :    
981 : sh002i 1873 sub if_warnings {
982 : sh002i 1131 my ($self, $arg) = @_;
983 : sh002i 1873 my $r = $self->r;
984 :    
985 :     if ($r->notes("warnings")) {
986 :     return $arg;
987 :     } else {
988 :     !$arg;
989 :     }
990 : sh002i 1131 }
991 :    
992 : sh002i 1861 =back
993 : sh002i 1131
994 : sh002i 1861 =cut
995 :    
996 : sh002i 1873 ################################################################################
997 : malsyned 508
998 : sh002i 1873 =head1 HTML MACROS
999 : malsyned 508
1000 : sh002i 1873 Various routines are defined in this package for rendering common WeBWorK
1001 :     idioms.
1002 :    
1003 :     FIXME: some of these should be moved to WeBWorK::HTML:: modules!
1004 :    
1005 :     # ------------------------------------------------------------------------------
1006 :    
1007 :     =head2 Template escape handler macros
1008 :    
1009 :     These methods are used by implementations of the escape sequence handlers to
1010 :     maintain a consistent style.
1011 :    
1012 :     =over
1013 :    
1014 :     =item pathMacro($args, @path)
1015 :    
1016 :     Helper macro for the C<#path> escape sequence: $args is a hash reference
1017 :     containing the "style", "image", "text", and "textonly" arguments to the escape.
1018 :     @path consists of ordered key-value pairs of the form:
1019 :    
1020 :     "Page Name" => URL
1021 :    
1022 :     If the page should not have a link associated with it, the URL should be left
1023 :     empty. Authentication data is added to each URL so you don't have to. A fully-
1024 :     formed path line is returned, suitable for returning by a function implementing
1025 :     the C<#path> escape.
1026 :    
1027 :     FIXME: authentication data probably shouldn't be added here any more, now that
1028 :     we have systemLink().
1029 :    
1030 :     =cut
1031 :    
1032 :     sub pathMacro {
1033 :     my ($self, $args, @path) = @_;
1034 :     my %args = %$args;
1035 :     $args{style} = "text" if $args{textonly};
1036 :    
1037 :     my $auth = $self->url_authen_args;
1038 :     my $sep;
1039 :     if ($args{style} eq "image") {
1040 :     $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}});
1041 :     } else {
1042 :     $sep = $args{text};
1043 :     }
1044 :    
1045 :     my @result;
1046 :     while (@path) {
1047 :     my $name = shift @path;
1048 :     my $url = shift @path;
1049 :     if ($url and not $args{textonly}) {
1050 :     push @result, CGI::a({-href=>"$url?$auth"}, $name);
1051 :     } else {
1052 :     push @result, $name;
1053 :     }
1054 :     }
1055 :    
1056 :     return join($sep, @result), "\n";
1057 :     }
1058 :    
1059 :     =item siblingsMacro(@siblings)
1060 :    
1061 :     Helper macro for the C<#siblings> escape sequence. @siblings consists of ordered
1062 :     key-value pairs of the form:
1063 :    
1064 :     "Sibling Name" => URL
1065 :    
1066 :     If the sibling should not have a link associated with it, the URL should be left
1067 :     empty. Authentication data is added to each URL so you don't have to. A fully-
1068 :     formed siblings block is returned, suitable for returning by a function
1069 :     implementing the C<#siblings> escape.
1070 :    
1071 :     FIXME: authentication data probably shouldn't be added here any more, now that
1072 :     we have systemLink().
1073 :    
1074 :     =cut
1075 :    
1076 :     sub siblingsMacro {
1077 :     my ($self, @siblings) = @_;
1078 :    
1079 :     my $auth = $self->url_authen_args;
1080 :     my $sep = CGI::br();
1081 :    
1082 :     my @result;
1083 :     while (@siblings) {
1084 :     my $name = shift @siblings;
1085 :     my $url = shift @siblings;
1086 :     push @result, $url
1087 :     ? CGI::a({-href=>"$url?$auth"}, $name)
1088 :     : $name;
1089 :     }
1090 :    
1091 :     return join($sep, @result) . "\n";
1092 :     }
1093 :    
1094 :     =item navMacro($args, $tail, @links)
1095 :    
1096 :     Helper macro for the C<#nav> escape sequence: $args is a hash reference
1097 :     containing the "style", "imageprefix", "imagesuffix", and "separator" arguments
1098 :     to the escape. @siblings consists of ordered tuples of the form:
1099 :    
1100 :     "Link Name", URL, ImageBaseName
1101 :    
1102 :     If the sibling should not have a link associated with it, the URL should be left
1103 :     empty. ImageBaseName is placed between the C<imageprefix> and C<imagesuffix>.
1104 :     Authentication data is added to each URL so you don't have to. $tail is appended
1105 :     to each URL, after the authentication information. A fully-formed nav line is
1106 :     returned, suitable for returning by a function implementing the C<#nav> escape.
1107 :    
1108 :     =cut
1109 :    
1110 :     sub navMacro {
1111 :     my ($self, $args, $tail, @links) = @_;
1112 :     my $r = $self->r;
1113 :     my $ce = $r->ce;
1114 :     my %args = %$args;
1115 :    
1116 :     my $auth = $self->url_authen_args;
1117 :     my $prefix = $ce->{webworkURLs}->{htdocs}."/images";
1118 :    
1119 :     my @result;
1120 :     while (@links) {
1121 :     my $name = shift @links;
1122 :     my $url = shift @links;
1123 :     my $img = shift @links;
1124 :     my $html =
1125 :     ($img && $args{style} eq "images")
1126 :     ? CGI::img(
1127 :     {src=>($prefix."/".$img.$args{imagesuffix}),
1128 :     border=>"",
1129 :     alt=>"$name"})
1130 :     : $name;
1131 :     unless($img && !$url) {
1132 :     push @result, $url
1133 :     ? CGI::a({-href=>"$url?$auth$tail"}, $html)
1134 :     : $html;
1135 :     }
1136 :     }
1137 :    
1138 :     return join($args{separator}, @result) . "\n";
1139 :     }
1140 :    
1141 :     =back
1142 :    
1143 :     =cut
1144 :    
1145 :     # ------------------------------------------------------------------------------
1146 :    
1147 :     =head2 Parameter management
1148 :    
1149 :     Methods for formatting request parameters as hidden form fields or query string
1150 :     fragments.
1151 :    
1152 :     =over
1153 :    
1154 :     =item hidden_fields(@fields)
1155 :    
1156 :     Return hidden <INPUT> tags for each field mentioned in @fields (or all fields if
1157 :     list is empty), taking data from the current request.
1158 :    
1159 :     =cut
1160 :    
1161 :     sub hidden_fields {
1162 :     my ($self, @fields) = @_;
1163 :     my $r = $self->r;
1164 :    
1165 :     @fields = $r->param unless @fields;
1166 :    
1167 :     my $html = "";
1168 :     foreach my $param (@fields) {
1169 :     my @values = $r->param($param);
1170 :     $html .= CGI::hidden($param, @values);
1171 :     }
1172 :     return $html;
1173 :     }
1174 :    
1175 :     =item hidden_authen_fields()
1176 :    
1177 :     Use hidden_fields to return hidden <INPUT> tags for request fields used in
1178 :     authentication.
1179 :    
1180 :     =cut
1181 :    
1182 :     sub hidden_authen_fields {
1183 :     my ($self) = @_;
1184 :    
1185 :     return $self->hidden_fields("user", "effectiveUser", "key");
1186 :     }
1187 :    
1188 :     =item url_args(@fields)
1189 :    
1190 :     Return a URL query string (without the leading `?') containing values for each
1191 :     field mentioned in @fields, or all fields if list is empty. Data is taken from
1192 :     the current request.
1193 :    
1194 :     =cut
1195 :    
1196 :     sub url_args {
1197 :     my ($self, @fields) = @_;
1198 :     my $r = $self->r;
1199 :    
1200 :     @fields = $r->param unless @fields;
1201 :    
1202 :     my @pairs;
1203 :     foreach my $param (@fields) {
1204 :     my @values = $r->param($param);
1205 :     foreach my $value (@values) {
1206 :     push @pairs, uri_escape($param) . "=" . uri_escape($value);
1207 :     }
1208 :     }
1209 :    
1210 :     return join("&", @pairs);
1211 :     }
1212 :    
1213 :     =item url_authen_args()
1214 :    
1215 :     Use url_args to return a URL query string for request fields used in
1216 :     authentication.
1217 :    
1218 :     =cut
1219 :    
1220 :     sub url_authen_args {
1221 :     my ($self) = @_;
1222 :    
1223 :     return $self->url_args("user", "effectiveUser", "key");
1224 :     }
1225 :    
1226 :     =item print_form_data($begin, $middle, $end, $omit)
1227 :    
1228 :     Return a string containing every request field not matched by the quoted reguar
1229 :     expression $omit, placing $begin before each field name, $middle between each
1230 :     field name and its value, and $end after each value. Values are taken from the
1231 :     current request.
1232 :    
1233 :     =cut
1234 :    
1235 :     sub print_form_data {
1236 :     my ($self, $begin, $middle, $end, $qr_omit) = @_;
1237 :     my $r=$self->r;
1238 :     my @form_data = $r->param;
1239 :    
1240 :     my $return_string = "";
1241 :     foreach my $name (@form_data) {
1242 :     next if ($qr_omit and $name =~ /$qr_omit/);
1243 :     my @values = $r->param($name);
1244 :     foreach my $variable (qw(begin name middle value end)) {
1245 :     # FIXME: can this loop be moved out of the enclosing loop?
1246 :     no strict 'refs';
1247 :     ${$variable} = "" unless defined ${$variable};
1248 :     }
1249 :     foreach my $value (@values) {
1250 :     $return_string .= "$begin$name$middle$value$end";
1251 :     }
1252 :     }
1253 :    
1254 :     return $return_string;
1255 :     }
1256 :    
1257 :     =back
1258 :    
1259 :     =cut
1260 :    
1261 :     # ------------------------------------------------------------------------------
1262 :    
1263 :     =head2 Utilities
1264 :    
1265 :     =over
1266 :    
1267 :     =item systemLink($urlpath, %options)
1268 :    
1269 :     Generate a link to another part of the system. $urlpath is WeBWorK::URLPath
1270 :     object from which the base path will be taken. %options can consist of:
1271 :    
1272 :     =over
1273 :    
1274 : sh002i 1882 =item params
1275 : sh002i 1873
1276 : sh002i 1911 Can be either a reference to an array or a reference to a hash.
1277 : sh002i 1873
1278 : sh002i 1911 If it is a reference to a hash, it maps parmaeter names to values. These
1279 :     parameters will be included in the generated link. If a value is an arrayref,
1280 :     the values of the array referenced will be used. If a value is undefined, the
1281 :     value from the current request will be used.
1282 : sh002i 1873
1283 : sh002i 1911 If C<params> is an arrayref, it is interpreted as a list of parameter names.
1284 :     These parameters will be included in the generated link, using the values from
1285 :     the current request.
1286 : sh002i 1873
1287 : sh002i 1911 Unless C<authen> is false (see below), the authentication parameters (C<user>,
1288 :     C<effectiveUser>, and C<key>) are included with their default values.
1289 : sh002i 1898
1290 : sh002i 1882 =item authen
1291 : sh002i 1873
1292 : sh002i 1911 If set to a false value, the authentication parameters (C<user>,
1293 :     C<effectiveUser>, and C<key>) are included in the the generated link unless
1294 :     explicitly listed in C<params>.
1295 : sh002i 1873
1296 :     =back
1297 :    
1298 :     =cut
1299 :    
1300 : sh002i 1882 # FIXME: there should probably be an option for prepending "http://hostname:port"
1301 : sh002i 1873 sub systemLink {
1302 :     my ($self, $urlpath, %options) = @_;
1303 :     my $r = $self->r;
1304 :    
1305 : sh002i 1911 my %params = ();
1306 : sh002i 1882 if (exists $options{params}) {
1307 : sh002i 1911 if (ref $options{params} eq "HASH") {
1308 :     %params = %{ $options{params} };
1309 :     } elsif (ref $options{params} eq "ARRAY") {
1310 :     my @names = @{ $options{params} };
1311 :     @params{@names} = ();
1312 :     } else {
1313 :     croak "option 'params' is not a hashref or an arrayref";
1314 :     }
1315 : sh002i 1882 }
1316 : sh002i 1873
1317 : sh002i 1893 my $authen = exists $options{authen} ? $options{authen} : 1;
1318 : sh002i 1911 if ($authen) {
1319 :     $params{user} = undef unless exists $params{user};
1320 :     $params{effectiveUser} = undef unless exists $params{effectiveUser};
1321 :     $params{key} = undef unless exists $params{key};
1322 : sh002i 1882 }
1323 :    
1324 : sh002i 1873 my $url = $r->location . $urlpath->path;
1325 : sh002i 1911 my $first = 1;
1326 : sh002i 1873
1327 : sh002i 1911 foreach my $name (keys %params) {
1328 :     my $value = $params{$name};
1329 :    
1330 :     my @values;
1331 :     if (defined $value) {
1332 :     if (ref $value eq "ARRAY") {
1333 :     @values = @$value;
1334 :     } else {
1335 :     @values = $value;
1336 :     }
1337 :     } elsif (defined $r->param($name)) {
1338 :     @values = $r->param($name);
1339 :     }
1340 :    
1341 :     if (@values) {
1342 :     if ($first) {
1343 :     $url .= "?";
1344 :     $first = 0;
1345 :     } else {
1346 :     $url .= "&";
1347 :     }
1348 :     $url .= join "&", map { "$name=$_" } @values;
1349 :     }
1350 : sh002i 1873 }
1351 :    
1352 :     return $url;
1353 :     }
1354 :    
1355 :     =item nbsp($string)
1356 :    
1357 :     If string consists of only whitespace, the HTML entity C<&nbsp;> is returned.
1358 :     Otherwise $string is returned.
1359 :    
1360 :     =cut
1361 :    
1362 :     sub nbsp {
1363 :     my $self = shift;
1364 :     my $str = shift;
1365 : sh002i 1974 (defined $str && $str =~/\S/) ? $str : '&nbsp;';
1366 : sh002i 1873 }
1367 :    
1368 :     =item errorOutput($error, $details)
1369 :    
1370 :     =cut
1371 :    
1372 :     sub errorOutput($$$) {
1373 :     my ($self, $error, $details) = @_;
1374 :     return
1375 :     CGI::h3("Software Error"),
1376 :     CGI::p(<<EOF),
1377 :     WeBWorK has encountered a software error while attempting to process this
1378 :     problem. It is likely that there is an error in the problem itself. If you are
1379 :     a student, contact your professor to have the error corrected. If you are a
1380 :     professor, please consut the error output below for more informaiton.
1381 :     EOF
1382 :     # FIXME: this message shouldn't refer the the "problem" since it is for general error reporting
1383 :     CGI::h3("Error messages"), CGI::p(CGI::tt($error)),
1384 :     CGI::h3("Error context"), CGI::p(CGI::tt($details));
1385 :     }
1386 :    
1387 :     =item warningOutput($warnings)
1388 :    
1389 :     =cut
1390 :    
1391 :     sub warningOutput($$) {
1392 :     my ($self, $warnings) = @_;
1393 :    
1394 :     my @warnings = split m/\n+/, $warnings;
1395 :    
1396 :     return
1397 :     CGI::h3("Software Warnings"),
1398 :     CGI::p(<<EOF),
1399 :     WeBWorK has encountered warnings while attempting to process this problem. It
1400 :     is likely that this indicates an error or ambiguity in the problem itself. If
1401 :     you are a student, contact your professor to have the problem corrected. If you
1402 :     are a professor, please consut the warning output below for more informaiton.
1403 :     EOF
1404 :     # FIXME: this message shouldn't refer the the "problem" since it is for general warning reporting
1405 :     CGI::h3("Warning messages"),
1406 :     CGI::ul(CGI::li(\@warnings));
1407 :     }
1408 :    
1409 :     =back
1410 :    
1411 : malsyned 508 =head1 AUTHOR
1412 :    
1413 : sh002i 1873 Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu and Sam Hathaway,
1414 :     sh002i (at) math.rochester.edu.
1415 : malsyned 508
1416 :     =cut
1417 : sh002i 1873
1418 :     1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9