[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 737 - (view) (download) (as text)

1 : sh002i 455 ################################################################################
2 : sh002i 494 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
3 : sh002i 455 # $Id$
4 :     ################################################################################
5 :    
6 : malsyned 313 package WeBWorK::ContentGenerator;
7 : malsyned 305
8 : sh002i 455 =head1 NAME
9 :    
10 :     WeBWorK::ContentGenerator - base class for modules that generate page content.
11 :    
12 :     =cut
13 :    
14 : malsyned 441 use strict;
15 :     use warnings;
16 : malsyned 323 use Apache::Constants qw(:common);
17 : sh002i 455 use CGI qw();
18 : sh002i 469 use URI::Escape;
19 : sh002i 526 use WeBWorK::DB::Auth;
20 : sh002i 476 use WeBWorK::Utils qw(readFile);
21 : sh002i 555 use Carp qw(cluck);
22 : malsyned 390
23 : sh002i 469 ################################################################################
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 : malsyned 390
28 : sh002i 469 # 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 :     #
34 :     # WeBWorK::ContentGenerator::WHATEVER->new($r, $ce)->go(@whatever);
35 :     #
36 :     # and throws away the result ;)
37 :     #
38 : malsyned 305 sub new($$$) {
39 : malsyned 323 my $invocant = shift;
40 :     my $class = ref($invocant) || $invocant;
41 : malsyned 305 my $self = {};
42 :     ($self->{r}, $self->{courseEnvironment}) = @_;
43 :     bless $self, $class;
44 :     return $self;
45 :     }
46 :    
47 : sh002i 469 ################################################################################
48 :     # Invocation and template processing
49 :     ################################################################################
50 : malsyned 323
51 : sh002i 469 # go(@otherArguments) - render a page, using methods from the particular
52 :     # subclass of ContentGenerator. @otherArguments is passed to each method, so
53 :     # that the dispatcher can pass CG-specific data. The order of calls looks like
54 :     # this:
55 :     #
56 :     # * &pre_header_initialize - give subclasses a chance to do initialization
57 :     # necessary for generating the HTTP header.
58 :     # * &header - this class provides a standard HTTP header with Content-Type
59 :     # text/html. Subclasses are welcome to overload this for things like
60 :     # an image-creation content generator or a PDF generator.
61 :     # * &initialize - let subclasses do post-header initialization.
62 :     # * any "template escapes" defined in the system template and supported by
63 :     # the subclass. Generic implementations of &title and &body are provided.
64 :     #
65 :     sub go {
66 :     my $self = shift;
67 :     my $r = $self->{r};
68 :     my $courseEnvironment = $self->{courseEnvironment};
69 :    
70 :     $self->pre_header_initialize(@_) if $self->can("pre_header_initialize");
71 :     $self->header(@_);
72 :     return OK if $r->header_only;
73 : malsyned 313
74 : sh002i 469 $self->initialize(@_) if $self->can("initialize");
75 :     $self->template($courseEnvironment->{templates}->{system}, @_);
76 : malsyned 441
77 : sh002i 469 return OK;
78 :     }
79 :    
80 :     # template(STRING, @otherArguments) - parse a template, looking for escapes of
81 :     # the form <!--#NAME ARG1="FOO" ARG2="BAR"--> and calling a member function NAME
82 :     # (if available) for each NAME. The escapes are called like:
83 :     #
84 :     # $self->NAME(@otherArguments, \%escapeArguments)
85 :     #
86 :     # where @otherArguments originates in the dispatcher and %escapeArguments is
87 :     # parsed out of the escape itself (i.e. ARG1 => FOO, ARG2 => BAR)
88 :     #
89 :     sub template {
90 :     my ($self, $templateFile) = (shift, shift);
91 :     my $r = $self->{r};
92 :     my $courseEnvironment = $self->{courseEnvironment};
93 : malsyned 512 my @ifstack = (1); # Start off in printing mode
94 :     # say $ifstack[-1] to get the result of the last <#!--if-->
95 : sh002i 469
96 : sh002i 476 # so even though the variable $/ APPEARS to contain a newline,
97 :     # <TEMPLATE> is slurping the whole file into the first element of
98 :     # @template ONLY AFTER THE TRANSLATOR RUNS. WTF!!!
99 :     #
100 :     #open(TEMPLATE, $templateFile) or die "Couldn't open template $templateFile";
101 :     #my @template = <TEMPLATE>;
102 :     #close TEMPLATE;
103 :     #
104 :     # Let's try something else instead:
105 :     my @template = split /\n/, readFile($templateFile);
106 :    
107 : sh002i 469 foreach my $line (@template) {
108 :     # This is incremental regex processing.
109 :     # the /c is so that pos($line) doesn't die when the regex fails.
110 :     while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) {
111 :     my ($before, $function, $raw_args) = ($1, $2, $3);
112 : sh002i 555 my @args = ($raw_args =~ /\S/) ? cook_args($raw_args) : ();
113 :    
114 : malsyned 512 if ($ifstack[-1]) {
115 :     print $before;
116 :     }
117 : sh002i 555
118 : sh002i 558 if ($function eq "if") {
119 :     push @ifstack, $self->$function(@_, [@args]);
120 :     } elsif ($function eq "else" and @ifstack > 1) {
121 :     $ifstack[-1] = not $ifstack[-1];
122 :     } elsif ($function eq "endif" and @ifstack > 1) {
123 :     pop @ifstack;
124 :     } elsif ($ifstack[-1]) {
125 : sh002i 562 if ($self->can($function)) {
126 :     print $self->$function(@_, {@args});
127 :     }
128 : sh002i 476 }
129 : malsyned 313 }
130 : sh002i 469
131 : malsyned 512 if ($ifstack[-1]) {
132 : sh002i 562 print substr($line, (defined pos $line) ? pos $line : 0), "\n";
133 : malsyned 512 }
134 : malsyned 313 }
135 : sh002i 469 }
136 :    
137 :     # cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns
138 : malsyned 512 # a list which pairs into key/values and fits nicely in {}s.
139 : sh002i 469 #
140 :     sub cook_args($) {
141 :     my ($raw_args) = @_;
142 : malsyned 512 my @args = ();
143 : malsyned 353
144 : malsyned 508 # Boy I love m//g in scalar context! Go read the camel book, heathen.
145 :     # First, get the whole token with the quotes on both ends...
146 :     while ($raw_args =~ m/\G\s*(\w*)="((?:[^"\\]|\\.)*)"/g) {
147 :     my ($key, $value) = ($1, $2);
148 :     # ... then, rip out all the protecty backspaces
149 : malsyned 522 $value =~ s/\\(.)/$1/g;
150 : malsyned 512 push @args, $key => $value;
151 : sh002i 469 }
152 :    
153 : malsyned 512 return @args;
154 : malsyned 313 }
155 :    
156 : sh002i 558 # This is different. It probably shouldn't print anything (except in debugging cases)
157 :     # and it should return a boolean, not a string. &if is called in a nonstandard way
158 :     # by &template, with $args as an arrayref instead of a hashref. this is a hack! yay!
159 :    
160 :     # OK, this is a pluggin architecture. it iterates through attributes of the "if" tag,
161 :     # and for each predicate $p, it calls &if_$p in an object-oriented way, continuing the
162 :     # grand templating theme of an object-oriented pluggable architecture using ->can($).
163 :     sub if {
164 :     my ($self, $args) = @_[0,-1];
165 :     # A single if "or"s it's components. Nesting produces "and".
166 :    
167 :     my @args = @$args; # Hahahahaha, get it?!
168 :    
169 :     if (@args % 2 != 0) {
170 :     # flip out and kill people, but do not commit seppuku
171 :     print '<!--&if recieved an uneven number of arguments. This shouldn\'t happen, but I\'ll let it slide.-->\n';
172 :     }
173 :    
174 :     while (@args > 1) {
175 :     my ($key, $value) = (shift @args, shift @args);
176 :    
177 :     # a non-existent &if_$key is the same as a false result, but we're ORing, so it's OK
178 :     my $sub = "if_$key"; # perl doesn't like it when you try to construct a string right in a method invocation
179 :     if ($self->can("if_$key") and $self->$sub("$value")) {
180 :     return 1;
181 :     }
182 :     }
183 :    
184 :     return 0;
185 :     }
186 :    
187 : sh002i 469 ################################################################################
188 :     # Macros used by content generators to render common idioms
189 :     ################################################################################
190 :    
191 :     # pathMacro(HASHREF, LIST) - helper macro for <!--#path--> escape: the hash
192 :     # reference contains the "style", "image", and "text" arguments to the escape.
193 :     # The LIST consists of ordered key-value pairs of the form:
194 :     #
195 :     # "Page Name" => URL
196 :     #
197 :     # If the page should not have a link associated with it, the URL should be left
198 :     # empty. Authentication data is added to the URL so you don't have to. A fully-
199 :     # formed path line is returned, suitable for returning by a function
200 :     # implementing the #path escape.
201 :     #
202 :     sub pathMacro {
203 : malsyned 323 my $self = shift;
204 : sh002i 469 my %args = %{ shift() };
205 :     my @path = @_;
206 :     my $sep;
207 :     if ($args{style} eq "image") {
208 :     $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}});
209 :     } else {
210 :     $sep = $args{text};
211 :     }
212 :     my $auth = $self->url_authen_args;
213 :     my @result;
214 :     while (@path) {
215 :     my $name = shift @path;
216 :     my $url = shift @path;
217 :     push @result, $url
218 :     ? CGI::a({-href=>"$url?$auth"}, $name)
219 :     : $name;
220 :     }
221 :     return join($sep, @result), "\n";
222 :     }
223 :    
224 :     sub siblingsMacro {
225 :     my $self = shift;
226 :     my @siblings = @_;
227 :     my $sep = CGI::br();
228 :     my $auth = $self->url_authen_args;
229 :     my @result;
230 :     while (@siblings) {
231 :     my $name = shift @siblings;
232 :     my $url = shift @siblings;
233 :     push @result, $url
234 :     ? CGI::a({-href=>"$url?$auth"}, $name)
235 :     : $name;
236 :     }
237 :     return join($sep, @result), "\n";
238 :     }
239 :    
240 :     sub navMacro {
241 :     my $self = shift;
242 :     my %args = %{ shift() };
243 : sh002i 692 my $tail = shift;
244 : sh002i 469 my @links = @_;
245 :     my $auth = $self->url_authen_args;
246 :     my @result;
247 :     while (@links) {
248 :     my $name = shift @links;
249 :     my $url = shift @links;
250 :     push @result, $url
251 : sh002i 692 ? CGI::a({-href=>"$url?$auth$tail"}, $name)
252 : sh002i 469 : $name;
253 :     }
254 :     return join($args{separator}, @result), "\n";
255 :     }
256 :    
257 :     # hidden_fields(LIST) - return hidden <INPUT> tags for each field mentioned in
258 :     # LIST (or all fields if list is empty), taking data from the current request.
259 :     #
260 :     sub hidden_fields($;@) {
261 :     my $self = shift;
262 : malsyned 323 my $r = $self->{r};
263 : sh002i 469 my @fields = @_;
264 :     @fields or @fields = $r->param;
265 : malsyned 323 my $courseEnvironment = $self->{courseEnvironment};
266 :     my $html = "";
267 :    
268 : sh002i 469 foreach my $param (@fields) {
269 : malsyned 323 my $value = $r->param($param);
270 : malsyned 447 $html .= CGI::input({-type=>"hidden",-name=>"$param",-value=>"$value"});
271 : malsyned 323 }
272 :     return $html;
273 :     }
274 :    
275 : sh002i 469 # hidden_authen_fields() - use hidden_fields to return hidden <INPUT> tags for
276 :     # request fields used in authentication.
277 :     #
278 :     sub hidden_authen_fields($) {
279 :     my $self = shift;
280 :     return $self->hidden_fields("user","effectiveUser","key");
281 :     }
282 : sh002i 425
283 : sh002i 469 # url_args(LIST) - return a URL query string (without the leading `?')
284 :     # containing values for each field mentioned in LIST, or all fields if list is
285 :     # empty. Data is taken from the current request.
286 :     #
287 :     sub url_args($;@) {
288 : sh002i 425 my $self = shift;
289 :     my $r = $self->{r};
290 :     my @fields = @_;
291 :     @fields or @fields = $r->param;
292 :     my $courseEnvironment = $self->{courseEnvironment};
293 :    
294 : sh002i 469 my @pairs;
295 : malsyned 441 foreach my $param (@fields) {
296 : sh002i 469 my $value = $r->param($param) || "";
297 :     push @pairs, uri_escape($param) . "=" . uri_escape($value);
298 : sh002i 425 }
299 : sh002i 469
300 :     return join("&", @pairs);
301 : sh002i 425 }
302 :    
303 : sh002i 469 # url_authen_args() - use url_args to return a URL query string for request
304 :     # fields used in authentication.
305 :     #
306 :     sub url_authen_args($) {
307 :     my $self = shift;
308 :     my $r = $self->{r};
309 :     return $self->url_args("user","effectiveUser","key");
310 : malsyned 390 }
311 :    
312 : sh002i 469 # print_form_data(BEGIN, MIDDLE, END, OMIT) - return a string containing request
313 :     # fields not matched by OMIT, placing BEGIN before each field name, MIDDLE
314 :     # between each field and its value, and END after each value. Values are taken
315 :     # from the current request. OMIT is a quoted reguar expression.
316 :     #
317 :     sub print_form_data {
318 :     my ($self, $begin, $middle, $end, $qr_omit) = @_;
319 :     my $return_string = "";
320 :     my $r=$self->{r};
321 :     my @form_data = $r->param;
322 :     foreach my $name (@form_data) {
323 :     next if ($qr_omit and $name =~ /$qr_omit/);
324 :     my @values = $r->param($name);
325 :     foreach my $variable (qw(begin name middle value end)) {
326 :     no strict 'refs';
327 :     ${$variable} = "" unless defined ${$variable};
328 :     }
329 :     foreach my $value (@values) {
330 :     $return_string .= "$begin$name$middle$value$end";
331 :     }
332 :     }
333 :     return $return_string;
334 : malsyned 390 }
335 :    
336 : sh002i 737 sub errorOutput($$$) {
337 :     my ($self, $error, $details) = @_;
338 :     return
339 :     CGI::h2("Software Error"),
340 :     CGI::p(<<EOF),
341 :     WeBWorK has encountered a software error while attempting to process this problem.
342 :     It is likely that there is an error in the problem itself.
343 :     If you are a student, contact your professor to have the error corrected.
344 :     If you are a professor, please consut the error output below for more informaiton.
345 :     EOF
346 :     CGI::h3("Error messages"), CGI::blockquote(CGI::pre($error)),
347 :     CGI::h3("Error context"), CGI::blockquote(CGI::pre($details));
348 :     }
349 :    
350 :     sub warningOutput($$) {
351 :     my ($self, $warnings) = @_;
352 :    
353 :     return
354 :     CGI::h2("Software Warnings"),
355 :     CGI::p(<<EOF),
356 :     WeBWorK has encountered warnings while attempting to process this problem.
357 :     It is likely that this indicates an error or ambiguity in the problem itself.
358 :     If you are a student, contact your professor to have the problem corrected.
359 :     If you are a professor, please consut the error output below for more informaiton.
360 :     EOF
361 :     CGI::h3("Warning messages"),
362 :     CGI::blockquote(CGI::pre($warnings)),
363 :     ;
364 :     }
365 :    
366 : sh002i 469 ################################################################################
367 :     # Generic versions of template escapes
368 :     ################################################################################
369 : malsyned 390
370 : sh002i 469 # Reminder: here are the template functions currently defined:
371 :     #
372 : sh002i 555 # head
373 : sh002i 469 # path
374 :     # style = text|image
375 :     # image = URL of image
376 :     # text = text separator
377 : sh002i 675 # loginstatus
378 : sh002i 505 # links
379 : sh002i 469 # siblings
380 :     # nav
381 :     # style = text|image
382 :     # imageprefix = prefix to image URL
383 :     # imagesuffix = suffix to image URL
384 :     # separator = HTML to place in between links
385 :     # title
386 :     # body
387 : malsyned 313
388 : malsyned 349 sub header {
389 : malsyned 305 my $self = shift;
390 : sh002i 469 my $r = $self->{r};
391 : malsyned 349 $r->content_type('text/html');
392 :     $r->send_http_header();
393 :     }
394 :    
395 : sh002i 682 sub loginstatus {
396 :     my $self = shift;
397 :     my $r = $self->{r};
398 :     my $user = $r->param("user");
399 :     my $eUser = $r->param("effectiveUser");
400 :     my $key = $r->param("key");
401 :     return "" unless $key;
402 : sh002i 692 my $exitURL = $r->uri() . "?user=$user&key=$key";
403 : sh002i 682 print CGI::small("Logged in as:", CGI::br(), "$user");
404 :     if ($user ne $eUser) {
405 : sh002i 692 print CGI::br(), CGI::font({-color=>'red'},
406 :     CGI::small("Acting as:", CGI::br(), "$eUser")
407 :     ),
408 :     CGI::br(), CGI::a({-href=>$exitURL},
409 :     CGI::small("Stop Acting")
410 :     );
411 : sh002i 682 }
412 :     return "";
413 :     }
414 :    
415 :     # *** drunk code. rewrite.
416 : sh002i 667 # also, this should be structured s.t. subclasses can add items to the links
417 :     # area, i.e. "stacking"
418 : sh002i 505 sub links {
419 : malsyned 353 my $self = shift;
420 : sh002i 469 my $ce = $self->{courseEnvironment};
421 : sh002i 526 my $userName = $self->{r}->param("user");
422 :     my $courseName = $ce->{courseName};
423 : sh002i 469 my $root = $ce->{webworkURLs}->{root};
424 : sh002i 526 my $permLevel = WeBWorK::DB::Auth->new($ce)->getPermissions($userName);
425 : sh002i 646 my $key = WeBWorK::DB::Auth->new($ce)->getKey($userName);
426 :     return "" unless defined $key;
427 : sh002i 526
428 : sh002i 667 # URLs to parts of the system
429 :     my $probSets = "$root/$courseName/?" . $self->url_authen_args();
430 : sh002i 644 my $prefs = "$root/$courseName/options/?" . $self->url_authen_args();
431 : sh002i 667 my $prof = "$root/$courseName/prof/?" . $self->url_authen_args();
432 :     my $help = "$ce->{webworkURLs}->{docs}?" . $self->url_authen_args();
433 :     my $logout = "$root/$courseName/logout/?" . $self->url_authen_args();
434 : sh002i 526
435 : sh002i 476 return
436 : sh002i 469 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(),
437 : sh002i 526 CGI::a({-href=>$prefs}, "User Options"), CGI::br(),
438 : sh002i 667 ($permLevel > 0
439 :     ? CGI::a({-href=>$prof}, "Professor") . CGI::br()
440 :     : ""),
441 : sh002i 526 CGI::a({-href=>$help}, "Help"), CGI::br(),
442 : sh002i 476 CGI::a({-href=>$logout}, "Log Out"), CGI::br(),
443 :     ;
444 : malsyned 353 }
445 :    
446 : malsyned 525 # &if_can will return 1 if the current object->can("do $_[1]")
447 :     sub if_can ($$) {
448 :     my ($self, $arg) = (@_);
449 :    
450 :     if ($self->can("$arg")) {
451 :     return 1;
452 :     } else {
453 :     return 0;
454 :     }
455 :     }
456 :    
457 : malsyned 313 1;
458 : malsyned 508
459 :     __END__
460 :    
461 :     =head1 AUTHOR
462 :    
463 :     Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu
464 :     and Sam Hathaway, sh002i (at) math.rochester.edu.
465 :    
466 :     =cut

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9