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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 305 Revision 1430
1################################################################################
2# WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
3# $Id$
4################################################################################
5
1package WeBWorK::ContentGenerator 6package WeBWorK::ContentGenerator;
2 7
8=head1 NAME
9
10WeBWorK::ContentGenerator - base class for modules that generate page content.
11
12=cut
13
14use strict;
15use warnings;
16use Apache::Constants qw(:common);
17use CGI qw();
18use URI::Escape;
19use WeBWorK::Authz;
20use WeBWorK::DB;
21use WeBWorK::Utils qw(readFile);
22
23################################################################################
24# This is a very unruly file, so I'm going to use very large comments to divide
25# it into logical sections.
26################################################################################
27
3# new(Apache::Request, WeBWorK::CourseEnvironment) 28# new(Apache::Request, WeBWorK::CourseEnvironment) - create a new instance of a
29# content generator. Usually only called by the dispatcher, although one might
30# be able to use it for things like "sub-requests". Uh... uh... I have to think
31# about that one. The dispatcher uses this idiom:
32#
33# WeBWorK::ContentGenerator::WHATEVER->new($r, $ce)->go(@whatever);
34#
35# and throws away the result ;)
36#
4sub new($$$) { 37sub new($$$$) {
5 my $class = shift; 38 my ($invocant, $r, $ce, $db) = @_;
39 my $class = ref($invocant) || $invocant;
6 my $self = {}; 40 my $self = {
7 ($self->{r}, $self->{courseEnvironment}) = @_; 41 r => $r,
42 ce => $ce,
43 db => $db,
44 authz => WeBWorK::Authz->new($r, $ce, $db),
45 noContent => undef, # false
46 };
8 bless $self, $class; 47 bless $self, $class;
9 return $self; 48 return $self;
10} 49}
11 50
12# standard_header(Apache::Request, Content-type, header => "value" ...) 51################################################################################
13#sub headers($$%) { 52# Invocation and template processing
14# ($r, $ct, %headers) = @_; 53################################################################################
15# $r->content_type($ct); 54
16# foreach my $key (keys %headers) { 55# go(@otherArguments) - render a page, using methods from the particular
17# $r->header_out($key, $headers{$key} 56# subclass of ContentGenerator. @otherArguments is passed to each method, so
57# that the dispatcher can pass CG-specific data. The order of calls looks like
58# this:
59#
60# * &pre_header_initialize - give subclasses a chance to do initialization
61# necessary for generating the HTTP header.
62# * &header - this class provides a standard HTTP header with Content-Type
63# text/html. Subclasses are welcome to overload this for things like
64# an image-creation content generator or a PDF generator.
65# In addition, if &header returns a value, that will be the value
66# returned by the entire PerlHandler.
67# * &initialize - let subclasses do post-header initialization.
68# * any "template escapes" defined in the system template and supported by
69# the subclass.
70# (if &content exists on a content generator, it is called
71# and no template processing occurs.)
72#
73# If &pre_header_initialize or &header sets $self->{noContent} to a true value,
74# &initialize will not be run and the content or template processing code
75# will not be executed. This is probably only desirable if a redirect has been
76# issued.
77sub go {
78 my $self = shift;
79
80 my $r = $self->{r};
81 my $ce = $self->{ce};
82 my $returnValue = OK;
83
84 $self->pre_header_initialize(@_) if $self->can("pre_header_initialize");
85 my $headerReturn = $self->header(@_);
86 $returnValue = $headerReturn if defined $headerReturn;
87 return $returnValue if $r->header_only or $self->{noContent};
88
89 $self->initialize(@_) if $self->can("initialize");
90
91 # A content generator will have a "content" method if it does not
92 # wish to be passed through template processing, but wishes to be
93 # completely responsible for it's own output.
94 if ($self->can("content")) {
95 $self->content(@_);
96 } else {
97 # if the content generator specifies a custom template name, use that
98 # field in the $ce->{templates} hash instead of "system" if it exists.
99 my $templateName;
100 if ($self->can("templateName")) {
101 $templateName = $self->templateName;
102 } else {
103 $templateName = "system";
104 }
105 $templateName = "system" unless exists $ce->{templates}->{$templateName};
106 $self->template($ce->{templates}->{$templateName}, @_);
18# } 107 }
19# $r->send_http_header; 108
20# 109 return $returnValue;
21# return 1 if $r->header_only; 110}
111
112# template(STRING, @otherArguments) - parse a template, looking for escapes of
113# the form <!--#NAME ARG1="FOO" ARG2="BAR"--> and calling a member function NAME
114# (if available) for each NAME. The escapes are called like:
115#
116# $self->NAME(@otherArguments, \%escapeArguments)
117#
118# where @otherArguments originates in the dispatcher and %escapeArguments is
119# parsed out of the escape itself (i.e. ARG1 => FOO, ARG2 => BAR)
120#
121sub template {
122 my ($self, $templateFile) = (shift, shift);
123 my $r = $self->{r};
124 my $courseEnvironment = $self->{ce};
125 my @ifstack = (1); # Start off in printing mode
126 # say $ifstack[-1] to get the result of the last <#!--if-->
127
128 # so even though the variable $/ APPEARS to contain a newline,
129 # <TEMPLATE> is slurping the whole file into the first element of
130 # @template ONLY AFTER THE TRANSLATOR RUNS. WTF!!!
131 #
132 #open(TEMPLATE, $templateFile) or die "Couldn't open template $templateFile";
133 #my @template = <TEMPLATE>;
134 #close TEMPLATE;
135 #
136 # Let's try something else instead:
137 my @template = split /\n/, readFile($templateFile);
138
139 foreach my $line (@template) {
140 # This is incremental regex processing.
141 # the /c is so that pos($line) doesn't die when the regex fails.
142 while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) {
143 my ($before, $function, $raw_args) = ($1, $2, $3);
144 my @args = ($raw_args =~ /\S/) ? cook_args($raw_args) : ();
145
146 if ($ifstack[-1]) {
147 print $before;
148 }
149
150 if ($function eq "if") {
151 # a predicate can only be true if everything else on the ifstack is already true, for ANDing
152 push @ifstack, ($self->$function(@_, [@args]) && $ifstack[-1]);
153 } elsif ($function eq "else" and @ifstack > 1) {
154 $ifstack[-1] = not $ifstack[-1];
155 } elsif ($function eq "endif" and @ifstack > 1) {
156 pop @ifstack;
157 } elsif ($ifstack[-1]) {
158 if ($self->can($function)) {
159 my @result = $self->$function(@_, {@args});
160 if (@result) {
161 print @result;
162 } else {
163 warn "Template escape $function returned an empty list.";
164 }
165 }
166 }
167 }
168
169 if ($ifstack[-1]) {
170 print substr($line, (defined pos $line) ? pos $line : 0), "\n";
171 }
172 }
173}
174
175# cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns
176# a list which pairs into key/values and fits nicely in {}s.
177#
178sub cook_args($) { # ... also used by bin/wwdb, so watch out
179 my ($raw_args) = @_;
180 my @args = ();
181
182 # Boy I love m//g in scalar context! Go read the camel book, heathen.
183 # First, get the whole token with the quotes on both ends...
184 while ($raw_args =~ m/\G\s*(\w*)="((?:[^"\\]|\\.)*)"/g) {
185 my ($key, $value) = ($1, $2);
186 # ... then, rip out all the protecty backspaces
187 $value =~ s/\\(.)/$1/g;
188 push @args, $key => $value;
189 }
190
191 return @args;
192}
193
194# This is different. It probably shouldn't print anything (except in debugging cases)
195# and it should return a boolean, not a string. &if is called in a nonstandard way
196# by &template, with $args as an arrayref instead of a hashref. this is a hack! yay!
197
198# OK, this is a pluggin architecture. it iterates through attributes of the "if" tag,
199# and for each predicate $p, it calls &if_$p in an object-oriented way, continuing the
200# grand templating theme of an object-oriented pluggable architecture using ->can($).
201sub if {
202 my ($self, $args) = @_[0,-1];
203 # A single if "or"s it's components. Nesting produces "and".
204
205 my @args = @$args; # Hahahahaha, get it?!
206
207 if (@args % 2 != 0) {
208 # flip out and kill people, but do not commit seppuku
209 print '<!--&if recieved an uneven number of arguments. This shouldn\'t happen, but I\'ll let it slide.-->\n';
210 }
211
212 while (@args > 1) {
213 my ($key, $value) = (shift @args, shift @args);
214
215 # a non-existent &if_$key is the same as a false result, but we're ORing, so it's OK
216 my $sub = "if_$key"; # perl doesn't like it when you try to construct a string right in a method invocation
217 if ($self->can("if_$key") and $self->$sub("$value")) {
218 return 1;
219 }
220 }
221
22# return 0; 222 return 0;
23#} 223}
24 224
25sub go($) { 225################################################################################
226# Macros used by content generators to render common idioms
227################################################################################
228
229# pathMacro(HASHREF, LIST) - helper macro for <!--#path--> escape: the hash
230# reference contains the "style", "image", and "text" arguments to the escape.
231# The LIST consists of ordered key-value pairs of the form:
232#
233# "Page Name" => URL
234#
235# If the page should not have a link associated with it, the URL should be left
236# empty. Authentication data is added to the URL so you don't have to. A fully-
237# formed path line is returned, suitable for returning by a function
238# implementing the #path escape.
239#
240sub pathMacro {
241 my $self = shift;
242 my %args = %{ shift() };
243 my @path = @_;
244 my $sep;
245 if ($args{style} eq "image") {
246 $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}});
247 } else {
248 $sep = $args{text};
249 }
250 my $auth = $self->url_authen_args;
251 my @result;
252 while (@path) {
253 my $name = shift @path;
254 my $url = shift @path;
255 push @result, $url
256 ? CGI::a({-href=>"$url?$auth"}, $name)
257 : $name;
258 }
259 return join($sep, @result) . "\n";
260}
261
262sub siblingsMacro {
263 my $self = shift;
264 my @siblings = @_;
265 my $sep = CGI::br();
266 my $auth = $self->url_authen_args;
267 my @result;
268 while (@siblings) {
269 my $name = shift @siblings;
270 my $url = shift @siblings;
271 push @result, $url
272 ? CGI::a({-href=>"$url?$auth"}, $name)
273 : $name;
274 }
275 return join($sep, @result), "\n";
276}
277
278sub navMacro {
279 my $self = shift;
280 my %args = %{ shift() };
26 my $self = shift; 281 my $tail = shift;
27 ($r, $ct, %headers) = @_; 282 my @links = @_;
28 $r->content_type($ct); 283 my $auth = $self->url_authen_args;
29 foreach $key (keys %headers) { 284 my $ce = $self->{ce};
30 $r->header_out($key, $headers{$key} 285 my $prefix = $ce->{webworkURLs}->{htdocs}."/images";
286 my @result;
287 while (@links) {
288 my $name = shift @links;
289 my $url = shift @links;
290 my $img = shift @links;
291 my $html =
292 ($img && $args{style} eq "images")
293 ? CGI::img(
294 {src=>($prefix."/".$img.$args{imagesuffix}),
295 border=>"",
296 alt=>"$name"})
297 : $name;
298 unless($img && !$url) {
299 push @result, $url
300 ? CGI::a({-href=>"$url?$auth$tail"}, $html)
301 : $html;
31 } 302 }
303 }
304 return join($args{separator}, @result) . "\n";
305}
306
307# hidden_fields(LIST) - return hidden <INPUT> tags for each field mentioned in
308# LIST (or all fields if list is empty), taking data from the current request.
309#
310sub hidden_fields($;@) {
311 my $self = shift;
312 my $r = $self->{r};
313 my @fields = @_;
314 @fields or @fields = $r->param;
315 my $courseEnvironment = $self->{ce};
316 my $html = "";
317
318 foreach my $param (@fields) {
319 my $value = $r->param($param);
320 $html .= CGI::input({-type=>"hidden",-name=>"$param",-value=>"$value"});
321 }
322 return $html;
323}
324
325# hidden_authen_fields() - use hidden_fields to return hidden <INPUT> tags for
326# request fields used in authentication.
327#
328sub hidden_authen_fields($) {
329 my $self = shift;
330 return $self->hidden_fields("user","effectiveUser","key");
331}
332
333# url_args(LIST) - return a URL query string (without the leading `?')
334# containing values for each field mentioned in LIST, or all fields if list is
335# empty. Data is taken from the current request.
336#
337sub url_args($;@) {
338 my $self = shift;
339 my $r = $self->{r};
340 my @fields = @_;
341 @fields or @fields = $r->param; # If no fields are passed in, do them all.
342 my $courseEnvironment = $self->{ce};
343
344 my @pairs;
345 foreach my $param (@fields) {
346 my @values = $r->param($param);
347 foreach my $value (@values) {
348 push @pairs, uri_escape($param) . "=" . uri_escape($value);
349 }
350 }
351
352 return join("&", @pairs);
353}
354
355# url_authen_args() - use url_args to return a URL query string for request
356# fields used in authentication.
357#
358sub url_authen_args($) {
359 my $self = shift;
360 my $r = $self->{r};
361 return $self->url_args("user","effectiveUser","key");
362}
363
364# print_form_data(BEGIN, MIDDLE, END, OMIT) - return a string containing request
365# fields not matched by OMIT, placing BEGIN before each field name, MIDDLE
366# between each field and its value, and END after each value. Values are taken
367# from the current request. OMIT is a quoted reguar expression.
368#
369sub print_form_data {
370 my ($self, $begin, $middle, $end, $qr_omit) = @_;
371 my $return_string = "";
372 my $r=$self->{r};
373 my @form_data = $r->param;
374 foreach my $name (@form_data) {
375 next if ($qr_omit and $name =~ /$qr_omit/);
376 my @values = $r->param($name);
377 foreach my $variable (qw(begin name middle value end)) {
378 no strict 'refs';
379 ${$variable} = "" unless defined ${$variable};
380 }
381 foreach my $value (@values) {
382 $return_string .= "$begin$name$middle$value$end";
383 }
384 }
385 return $return_string;
386}
387
388sub errorOutput($$$) {
389 my ($self, $error, $details) = @_;
390 return
391 CGI::h3("Software Error"),
392 CGI::p(<<EOF),
393WeBWorK has encountered a software error while attempting to process this
394problem. It is likely that there is an error in the problem itself. If you are
395a student, contact your professor to have the error corrected. If you are a
396professor, please consut the error output below for more informaiton.
397EOF
398 CGI::h3("Error messages"), CGI::p(CGI::tt($error)),
399 CGI::h3("Error context"), CGI::p(CGI::tt($details));
400}
401
402sub warningOutput($$) {
403 my ($self, $warnings) = @_;
404
405 my @warnings = split m/\n+/, $warnings;
406
407 return
408 CGI::h3("Software Warnings"),
409 CGI::p(<<EOF),
410WeBWorK has encountered warnings while attempting to process this problem. It
411is likely that this indicates an error or ambiguity in the problem itself. If
412you are a student, contact your professor to have the problem corrected. If you
413are a professor, please consut the warning output below for more informaiton.
414EOF
415 CGI::h3("Warning messages"),
416 CGI::ul(CGI::li(\@warnings)),
417 ;
418}
419
420################################################################################
421# Generic versions of template escapes
422################################################################################
423
424# Reminder: here are the template functions currently defined:
425# FIXME: this list is out of date!!!!!!!!
426#
427# head
428# path
429# style = text|image
430# image = URL of image
431# text = text separator
432# loginstatus
433# links
434# siblings
435# nav
436# style = text|image
437# imageprefix = prefix to image URL
438# imagesuffix = suffix to image URL
439# separator = HTML to place in between links
440# title
441# body
442
443sub header {
444 my $self = shift;
445 my $r = $self->{r};
446 $r->content_type('text/html');
32 $r->send_http_header; 447 $r->send_http_header();
448 return OK;
449}
450
451sub loginstatus {
452 my $self = shift;
453 my $r = $self->{r};
454 my $user = $r->param("user");
455 my $eUser = $r->param("effectiveUser");
456 my $key = $r->param("key");
457 return "" unless $key;
458 my $exitURL = $r->uri() . "?user=$user&key=$key";
459 print CGI::small("User:", "$user");
460 if ($user ne $eUser) {
461 print CGI::br(), CGI::font({-color=>'red'},
462 CGI::small("Acting as:", "$eUser")
463 ),
464 CGI::br(), CGI::a({-href=>$exitURL},
465 CGI::small("Stop Acting")
466 );
467 }
468 return "";
469}
470
471# FIXME: drunk code. rewrite.
472# also, this should be structured s.t. subclasses can add items to the links
473# area, i.e. "stacking"
474sub links {
475 my $self = shift;
476 my @components = @_;
477 my $ce = $self->{ce};
478 my $db = $self->{db};
479 my $userName = $self->{r}->param("user");
480 my $courseName = $ce->{courseName};
481 my $root = $ce->{webworkURLs}->{root};
482 my $permLevel = $db->getPermissionLevel($userName)->permission();
483 my $key = $db->getKey($userName)->key();
484 return "" unless defined $key;
33 485
34 return OK if $r->header_only; 486 # URLs to parts of the system
487 my $probSets = "$root/$courseName/?" . $self->url_authen_args();
488 my $prefs = "$root/$courseName/options/?" . $self->url_authen_args();
489 my $help = "$ce->{webworkURLs}->{docs}?" . $self->url_authen_args();
490 my $logout = "$root/$courseName/logout/?" . $self->url_authen_args();
35 491
492 return join("",
493 CGI::a({-href=>$probSets}, "Problem&nbsp;Sets"), CGI::br(),
494 CGI::a({-href=>$prefs}, "User&nbsp;Prefs"), CGI::br(),
495 CGI::a({-href=>$help}, "Help"), CGI::br(),
496 CGI::a({-href=>$logout}, "Log Out"), CGI::br(),
497 ($permLevel > 0
498 ? $self->instructor_links(@components) : ""
499 ),
500 );
501}
502sub instructor_links {
503 my $self = shift;
504 my @components = @_;
505 my $args = pop(@components); # get hash of option arguments
506 my $courseName = $self->{ce}->{courseName};
507 my $root = $self->{ce}->{webworkURLs}->{root};
508 my ($set, $prob) = @components;
509 my $instructor = "$root/$courseName/instructor/?" . $self->url_authen_args();
510 my $sets = "$root/$courseName/instructor/sets/?" . $self->url_authen_args();
511 my $users = "$root/$courseName/instructor/users/?" . $self->url_authen_args();
512 my $email = "$root/$courseName/instructor/send_mail/?" . $self->url_authen_args();
36 513
514 my $stats = "$root/$courseName/instructor/stats/".((defined($set))?$set:''.'/?') . $self->url_authen_args();
515
516 # Add direct links to sets e.g. 3:4 for set3 problem 4
517 my $setURL = (defined($set)) ? "$root/$courseName/instructor/sets/$set/?" .
518 $self->url_authen_args() : '';
519 my $probURL = (defined($set) && defined($prob)) ? "$root/$courseName/instructor/pgProblemEditor/$set/$prob?" .
520 $self->url_authen_args() : '';
521 my $setProb = ($setURL) ? CGI::a({-href=>$setURL},$set ) : '';
522
523 $setProb .= ':'.CGI::a({-href=>$probURL},$prob) if $setProb && $probURL;
524 join("",
525 CGI::hr(),
526 CGI::a({-href=>$instructor}, "Instructor") , CGI::br(),
527 '&nbsp;&nbsp;',CGI::a({-href=>$sets}, "Set&nbsp;List") ,':', $setProb, CGI::br(),
528 '&nbsp;&nbsp;',CGI::a({-href=>$users}, "Class&nbsp;List") , CGI::br(),
529 '&nbsp;&nbsp;',CGI::a({-href=>$email}, "Send&nbsp;Email") , CGI::br(),
530 '&nbsp;&nbsp;',CGI::a({-href=>$stats}, 'Statistics'.((defined($set)) ? ":$set":'')),
531 CGI::br(), #FIXME (have index for stats page someday
532
533 )
534
535}
536# &if_can will return 1 if the current object->can("do $_[1]")
537sub if_can ($$) {
538 my ($self, $arg) = (@_);
539
540 if ($self->can("$arg")) {
541 return 1;
542 } else {
543 return 0;
544 }
545}
546
547# Every content generator is logged in unless it says otherwise.
548sub if_loggedin($$) {
549 my ($self, $arg) = (@_);
550
551 return $arg;
552}
553
554# Handling of errors in submissions
555
556sub if_submiterror($$) {
557 my ($self, $arg) = @_;
558 if (exists $self->{submitError}) {
559 return $arg;
560 } else {
561 return !$arg;
562 }
563}
564
565sub submiterror {
566 my ($self) = @_;
567 if (exists $self->{submitError}) {
568 return $self->{submitError};
569 } else {
570 return "";
571 }
572}
573
574# General warning handling
575
576sub if_warnings($$) {
577 my ($self, $arg) = @_;
578 return $self->{r}->notes("warnings") ? $arg : !$arg;
579}
580
581sub warnings {
582 my ($self) = @_;
583 my $r = $self->{r};
584 if ($r->notes("warnings")) {
585 return $self->warningOutput($r->notes("warnings"));
586 } else {
587 return "";
588 }
589}
590
5911;
592
593__END__
594
595=head1 AUTHOR
596
597Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu
598and Sam Hathaway, sh002i (at) math.rochester.edu.
599
600=cut
Legend:
Removed from v.305  
changed lines
  Added in v.1430
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9