[system] / branches / rel-2-1-patches / webwork-modperl / lib / WeBWorK / ContentGenerator.pm Repository:
ViewVC logotype

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

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

Revision 353 Revision 558
1################################################################################
2# WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
3# $Id$
4################################################################################
5
1package WeBWorK::ContentGenerator; 6package WeBWorK::ContentGenerator;
2 7
3use CGI qw(-compile :html :form); 8=head1 NAME
9
10WeBWorK::ContentGenerator - base class for modules that generate page content.
11
12=cut
13
14use strict;
15use warnings;
4use Apache::Constants qw(:common); 16use Apache::Constants qw(:common);
17use CGI qw();
18use URI::Escape;
19use WeBWorK::DB::Auth;
20use WeBWorK::Utils qw(readFile);
21use Carp qw(cluck);
5 22
6# This is a superclass for Apache::WeBWorK's content generators. 23################################################################################
7# You are /definitely/ encouraged to read this file, since there are 24# This is a very unruly file, so I'm going to use very large comments to divide
8# "abstract" functions here which show aproximately what form you would 25# it into logical sections.
9# want over-ridden sub-classes to follow. go() is a particularly pertinent 26################################################################################
10# example.
11 27
12# 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#
34# WeBWorK::ContentGenerator::WHATEVER->new($r, $ce)->go(@whatever);
35#
36# and throws away the result ;)
37#
13sub new($$$) { 38sub new($$$) {
14 my $invocant = shift; 39 my $invocant = shift;
15 my $class = ref($invocant) || $invocant; 40 my $class = ref($invocant) || $invocant;
16 my $self = {}; 41 my $self = {};
17 ($self->{r}, $self->{courseEnvironment}) = @_; 42 ($self->{r}, $self->{courseEnvironment}) = @_;
18 bless $self, $class; 43 bless $self, $class;
19 return $self; 44 return $self;
20} 45}
21 46
47################################################################################
48# Invocation and template processing
49################################################################################
22 50
23# This is a quick and dirty function to print out all (or almost all) of the 51# go(@otherArguments) - render a page, using methods from the particular
24# fields in a form in a specified format. As you can see from the print 52# subclass of ContentGenerator. @otherArguments is passed to each method, so
25# statement, it just prints out $begining$name$middle$value$end for every 53# that the dispatcher can pass CG-specific data. The order of calls looks like
26# field who's name doesn't match $qr_omit, a quoted regex. 54# this:
27# In it's current incarnation, it should be called from subclasses only, 55#
28# by saying $self->print_form_data. Of course, you could construct a 56# * &pre_header_initialize - give subclasses a chance to do initialization
29# hashref with ->{r} being an Apache::Request, I suppose. 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#
65sub go {
66 my $self = shift;
67 my $r = $self->{r};
68 my $courseEnvironment = $self->{courseEnvironment};
30 69
70 $self->pre_header_initialize(@_) if $self->can("pre_header_initialize");
71 $self->header(@_);
72 return OK if $r->header_only;
73
74 $self->initialize(@_) if $self->can("initialize");
75 $self->template($courseEnvironment->{templates}->{system}, @_);
76
77 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#
89sub template {
90 my ($self, $templateFile) = (shift, shift);
91 my $r = $self->{r};
92 my $courseEnvironment = $self->{courseEnvironment};
93 my @ifstack = (1); # Start off in printing mode
94 # say $ifstack[-1] to get the result of the last <#!--if-->
95
96 # 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 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 my @args = ($raw_args =~ /\S/) ? cook_args($raw_args) : ();
113
114 if ($ifstack[-1]) {
115 print $before;
116 }
117
118 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 print $self->$function(@_, {@args}) if $self->can($function);
126 }
127 }
128
129 if ($ifstack[-1]) {
130 print substr $line, (defined pos $line) ? pos $line : 0;
131 }
132 }
133}
134
135# cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns
136# a list which pairs into key/values and fits nicely in {}s.
137#
138sub cook_args($) {
139 my ($raw_args) = @_;
140 my @args = ();
141
142 # Boy I love m//g in scalar context! Go read the camel book, heathen.
143 # First, get the whole token with the quotes on both ends...
144 while ($raw_args =~ m/\G\s*(\w*)="((?:[^"\\]|\\.)*)"/g) {
145 my ($key, $value) = ($1, $2);
146 # ... then, rip out all the protecty backspaces
147 $value =~ s/\\(.)/$1/g;
148 push @args, $key => $value;
149 }
150
151 return @args;
152}
153
154# This is different. It probably shouldn't print anything (except in debugging cases)
155# and it should return a boolean, not a string. &if is called in a nonstandard way
156# by &template, with $args as an arrayref instead of a hashref. this is a hack! yay!
157
158# OK, this is a pluggin architecture. it iterates through attributes of the "if" tag,
159# and for each predicate $p, it calls &if_$p in an object-oriented way, continuing the
160# grand templating theme of an object-oriented pluggable architecture using ->can($).
161sub if {
162 my ($self, $args) = @_[0,-1];
163 # A single if "or"s it's components. Nesting produces "and".
164
165 my @args = @$args; # Hahahahaha, get it?!
166
167 if (@args % 2 != 0) {
168 # flip out and kill people, but do not commit seppuku
169 print '<!--&if recieved an uneven number of arguments. This shouldn\'t happen, but I\'ll let it slide.-->\n';
170 }
171
172 while (@args > 1) {
173 my ($key, $value) = (shift @args, shift @args);
174
175 # a non-existent &if_$key is the same as a false result, but we're ORing, so it's OK
176 my $sub = "if_$key"; # perl doesn't like it when you try to construct a string right in a method invocation
177 if ($self->can("if_$key") and $self->$sub("$value")) {
178 return 1;
179 }
180 }
181
182 return 0;
183}
184
185################################################################################
186# Macros used by content generators to render common idioms
187################################################################################
188
189# pathMacro(HASHREF, LIST) - helper macro for <!--#path--> escape: the hash
190# reference contains the "style", "image", and "text" arguments to the escape.
191# The LIST consists of ordered key-value pairs of the form:
192#
193# "Page Name" => URL
194#
195# If the page should not have a link associated with it, the URL should be left
196# empty. Authentication data is added to the URL so you don't have to. A fully-
197# formed path line is returned, suitable for returning by a function
198# implementing the #path escape.
199#
200sub pathMacro {
201 my $self = shift;
202 my %args = %{ shift() };
203 my @path = @_;
204 my $sep;
205 if ($args{style} eq "image") {
206 $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}});
207 } else {
208 $sep = $args{text};
209 }
210 my $auth = $self->url_authen_args;
211 my @result;
212 while (@path) {
213 my $name = shift @path;
214 my $url = shift @path;
215 push @result, $url
216 ? CGI::a({-href=>"$url?$auth"}, $name)
217 : $name;
218 }
219 return join($sep, @result), "\n";
220}
221
222sub siblingsMacro {
223 my $self = shift;
224 my @siblings = @_;
225 my $sep = CGI::br();
226 my $auth = $self->url_authen_args;
227 my @result;
228 while (@siblings) {
229 my $name = shift @siblings;
230 my $url = shift @siblings;
231 push @result, $url
232 ? CGI::a({-href=>"$url?$auth"}, $name)
233 : $name;
234 }
235 return join($sep, @result), "\n";
236}
237
238sub navMacro {
239 my $self = shift;
240 my %args = %{ shift() };
241 my @links = @_;
242 my $auth = $self->url_authen_args;
243 my @result;
244 while (@links) {
245 my $name = shift @links;
246 my $url = shift @links;
247 push @result, $url
248 ? CGI::a({-href=>"$url?$auth"}, $name)
249 : $name;
250 }
251 return join($args{separator}, @result), "\n";
252}
253
254# hidden_fields(LIST) - return hidden <INPUT> tags for each field mentioned in
255# LIST (or all fields if list is empty), taking data from the current request.
256#
257sub hidden_fields($;@) {
258 my $self = shift;
259 my $r = $self->{r};
260 my @fields = @_;
261 @fields or @fields = $r->param;
262 my $courseEnvironment = $self->{courseEnvironment};
263 my $html = "";
264
265 foreach my $param (@fields) {
266 my $value = $r->param($param);
267 $html .= CGI::input({-type=>"hidden",-name=>"$param",-value=>"$value"});
268 }
269 return $html;
270}
271
272# hidden_authen_fields() - use hidden_fields to return hidden <INPUT> tags for
273# request fields used in authentication.
274#
275sub hidden_authen_fields($) {
276 my $self = shift;
277 return $self->hidden_fields("user","effectiveUser","key");
278}
279
280# url_args(LIST) - return a URL query string (without the leading `?')
281# containing values for each field mentioned in LIST, or all fields if list is
282# empty. Data is taken from the current request.
283#
284sub url_args($;@) {
285 my $self = shift;
286 my $r = $self->{r};
287 my @fields = @_;
288 @fields or @fields = $r->param;
289 my $courseEnvironment = $self->{courseEnvironment};
290
291 my @pairs;
292 foreach my $param (@fields) {
293 my $value = $r->param($param) || "";
294 push @pairs, uri_escape($param) . "=" . uri_escape($value);
295 }
296
297 return join("&", @pairs);
298}
299
300# url_authen_args() - use url_args to return a URL query string for request
301# fields used in authentication.
302#
303sub url_authen_args($) {
304 my $self = shift;
305 my $r = $self->{r};
306 return $self->url_args("user","effectiveUser","key");
307}
308
309# print_form_data(BEGIN, MIDDLE, END, OMIT) - return a string containing request
310# fields not matched by OMIT, placing BEGIN before each field name, MIDDLE
311# between each field and its value, and END after each value. Values are taken
312# from the current request. OMIT is a quoted reguar expression.
313#
31sub print_form_data { 314sub print_form_data {
32 my ($self, $begin, $middle, $end, $qr_omit) = @_; 315 my ($self, $begin, $middle, $end, $qr_omit) = @_;
33 my $return_string = ""; 316 my $return_string = "";
34
35 $r=$self->{r}; 317 my $r=$self->{r};
36 my @form_data = $r->param; 318 my @form_data = $r->param;
37 foreach my $name (@form_data) { 319 foreach my $name (@form_data) {
38 next if ($qr_omit and $name =~ /$qr_omit/); 320 next if ($qr_omit and $name =~ /$qr_omit/);
39 my @values = $r->param($name); 321 my @values = $r->param($name);
322 foreach my $variable (qw(begin name middle value end)) {
323 no strict 'refs';
324 ${$variable} = "" unless defined ${$variable};
325 }
40 foreach my $value (@values) { 326 foreach my $value (@values) {
41 $return_string .= "$begin$name$middle$value$end"; 327 $return_string .= "$begin$name$middle$value$end";
42 } 328 }
43 } 329 }
44
45 return $return_string; 330 return $return_string;
46} 331}
47 332
48sub hidden_authen_fields { 333################################################################################
49 my $self = shift; 334# Generic versions of template escapes
50 my $r = $self->{r}; 335################################################################################
51 my $courseEnvironment = $self->{courseEnvironment};
52 my $html = "";
53
54 foreach $param ("user","key") {
55 my $value = $r->param($param);
56 $html .= input({-type=>"hidden",-name=>"$param",-value=>"$value"});
57 }
58 return $html;
59}
60 336
61sub pre_header_initialize {} 337# Reminder: here are the template functions currently defined:
338#
339# head
340# path
341# style = text|image
342# image = URL of image
343# text = text separator
344# links
345# siblings
346# nav
347# style = text|image
348# imageprefix = prefix to image URL
349# imagesuffix = suffix to image URL
350# separator = HTML to place in between links
351# title
352# body
62 353
63sub header { 354sub header {
64 my $self = shift; 355 my $self = shift;
65 my $r=$self->{r}; 356 my $r = $self->{r};
66 $r->content_type('text/html'); 357 $r->content_type('text/html');
67 $r->send_http_header(); 358 $r->send_http_header();
68} 359}
69 360
70sub initialize {} 361# drunk code. rewrite.
71 362sub links {
72sub title {
73 return "Superclass";
74}
75
76sub body {
77 print "Generated content";
78 "";
79}
80
81sub logo {
82 my $self = shift; 363 my $self = shift;
83 return $self->{courseEnvironment}->{urls}->{logo};
84}
85
86sub htdocs_base {
87 my $self = shift;
88 return $self->{courseEnvironment}->{urls}->{base};
89}
90
91sub go {
92 my $self = shift;
93 my $r = $self->{r};
94 my $courseEnvironment = $self->{courseEnvironment}; 364 my $ce = $self->{courseEnvironment};
95 365 my $userName = $self->{r}->param("user");
96 $self->pre_header_initialize(@_); 366 my $courseName = $ce->{courseName};
97 $self->header(@_); return OK if $r->header_only; 367 my $root = $ce->{webworkURLs}->{root};
98 $self->initialize(@_); 368 my $permLevel = WeBWorK::DB::Auth->new($ce)->getPermissions($userName);
99 369
100 my $templateFile = $courseEnvironment->{templates}->{system}; 370 my $probSets = "$root/$courseName/?" . $self->url_authen_args();
101 371 my $prefs = "$root/$courseName/prefs/?" . $self->url_authen_args();
102 open(TEMPLATE, $templateFile) or die "Couldn't open template $templateFile"; 372 my $prof = "$root/$courseName/prof/?" . $self->url_authen_args();
103 my @template = <TEMPLATE>; 373 my $profLine;
104 close TEMPLATE; 374 if ($permLevel > 0) {
105 375 $profLine = CGI::a({-href=>$prof}, "Professor") . CGI::br(),
106 foreach my $line (@template) {
107 # This is incremental regex processing.
108 # the /c is so that pos($line) doesn't die when the regex fails.
109 while ($line =~ m/\G(.*?)<!--#(.*?)\s*-->/gc) {
110 print "$1";
111 print $self->$2(@_) if $self->can($2);
112 } 376 }
113 # I thought I could use pos($line) here, but /noooooo/ 377 my $help = $ce->{webworkURLs}->{docs} . "?" . $self->url_authen_args();
114 print substr $line, pos($line); 378 my $logout = "$root/$courseName/?user=$userName";
115 }
116 379
380 return
381 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(),
382 CGI::a({-href=>$prefs}, "User Options"), CGI::br(),
383 $profLine,
384 CGI::a({-href=>$help}, "Help"), CGI::br(),
385 CGI::a({-href=>$logout}, "Log Out"), CGI::br(),
386 ;
387}
388
389# &if_can will return 1 if the current object->can("do $_[1]")
390sub if_can ($$) {
391 my ($self, $arg) = (@_);
392
393 if ($self->can("$arg")) {
117 return OK; 394 return 1;
395 } else {
396 return 0;
397 }
118} 398}
119 399
1201; 4001;
401
402__END__
403
404=head1 AUTHOR
405
406Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu
407and Sam Hathaway, sh002i (at) math.rochester.edu.
408
409=cut
Legend:
Removed from v.353  
changed lines
  Added in v.558
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9