[system] / trunk / webwork-modperl / lib / WeBWorK / ContentGenerator.pm Repository:
ViewVC logotype

Diff of /trunk/webwork-modperl/lib/WeBWorK/ContentGenerator.pm

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

Revision 522 Revision 737
… …
14use strict; 14use strict;
15use warnings; 15use warnings;
16use Apache::Constants qw(:common); 16use Apache::Constants qw(:common);
17use CGI qw(); 17use CGI qw();
18use URI::Escape; 18use URI::Escape;
19use WeBWorK::DB::Auth;
19use WeBWorK::Utils qw(readFile); 20use WeBWorK::Utils qw(readFile);
20#use CGI::Carp qw(fatalsToBrowser); 21use Carp qw(cluck);
21 22
22################################################################################ 23################################################################################
23# This is a very unruly file, so I'm going to use very large comments to divide 24# This is a very unruly file, so I'm going to use very large comments to divide
24# it into logical sections. 25# it into logical sections.
25################################################################################ 26################################################################################
… …
102 # 103 #
103 # Let's try something else instead: 104 # Let's try something else instead:
104 my @template = split /\n/, readFile($templateFile); 105 my @template = split /\n/, readFile($templateFile);
105 106
106 foreach my $line (@template) { 107 foreach my $line (@template) {
107 #warn "foo: $line\n";
108 # This is incremental regex processing. 108 # This is incremental regex processing.
109 # the /c is so that pos($line) doesn't die when the regex fails. 109 # the /c is so that pos($line) doesn't die when the regex fails.
110 while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) { 110 while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) {
111 my ($before, $function, $raw_args) = ($1, $2, $3); 111 my ($before, $function, $raw_args) = ($1, $2, $3);
112 # $args here will be a hashref
113 my @args = $raw_args =~ /\S/ ? cook_args($raw_args) : {}; 112 my @args = ($raw_args =~ /\S/) ? cook_args($raw_args) : ();
113
114 if ($ifstack[-1]) { 114 if ($ifstack[-1]) {
115 print $before; 115 print $before;
116 } 116 }
117 117
118 if ($self->can($function)) {
119 if ($function eq "if") { 118 if ($function eq "if") {
120 push @ifstack, $self->$function(@_, [@args]); 119 push @ifstack, $self->$function(@_, [@args]);
121 } elsif ($function eq "else" and @ifstack > 1) { 120 } elsif ($function eq "else" and @ifstack > 1) {
122 $ifstack[-1] = not $ifstack[-1]; 121 $ifstack[-1] = not $ifstack[-1];
123 } elsif ($function eq "endif" and @ifstack > 1) { 122 } elsif ($function eq "endif" and @ifstack > 1) {
124 pop @ifstack; 123 pop @ifstack;
125 } elsif ($ifstack[-1]) { 124 } elsif ($ifstack[-1]) {
125 if ($self->can($function)) {
126 print $self->$function(@_, {@args}); 126 print $self->$function(@_, {@args});
127 } 127 }
128 } 128 }
129 } 129 }
130 130
131 if ($ifstack[-1]) { 131 if ($ifstack[-1]) {
132 print substr $line, (defined pos $line) ? pos $line : 0; 132 print substr($line, (defined pos $line) ? pos $line : 0), "\n";
133 } 133 }
134 } 134 }
135} 135}
136 136
137# cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns 137# cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns
… …
149 $value =~ s/\\(.)/$1/g; 149 $value =~ s/\\(.)/$1/g;
150 push @args, $key => $value; 150 push @args, $key => $value;
151 } 151 }
152 152
153 return @args; 153 return @args;
154}
155
156# 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($).
163sub 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;
154} 185}
155 186
156################################################################################ 187################################################################################
157# Macros used by content generators to render common idioms 188# Macros used by content generators to render common idioms
158################################################################################ 189################################################################################
… …
207} 238}
208 239
209sub navMacro { 240sub navMacro {
210 my $self = shift; 241 my $self = shift;
211 my %args = %{ shift() }; 242 my %args = %{ shift() };
243 my $tail = shift;
212 my @links = @_; 244 my @links = @_;
213 my $auth = $self->url_authen_args; 245 my $auth = $self->url_authen_args;
214 my @result; 246 my @result;
215 while (@links) { 247 while (@links) {
216 my $name = shift @links; 248 my $name = shift @links;
217 my $url = shift @links; 249 my $url = shift @links;
218 push @result, $url 250 push @result, $url
219 ? CGI::a({-href=>"$url?$auth"}, $name) 251 ? CGI::a({-href=>"$url?$auth$tail"}, $name)
220 : $name; 252 : $name;
221 } 253 }
222 return join($args{separator}, @result), "\n"; 254 return join($args{separator}, @result), "\n";
223} 255}
224 256
… …
299 } 331 }
300 } 332 }
301 return $return_string; 333 return $return_string;
302} 334}
303 335
336sub errorOutput($$$) {
337 my ($self, $error, $details) = @_;
338 return
339 CGI::h2("Software Error"),
340 CGI::p(<<EOF),
341WeBWorK has encountered a software error while attempting to process this problem.
342It is likely that there is an error in the problem itself.
343If you are a student, contact your professor to have the error corrected.
344If you are a professor, please consut the error output below for more informaiton.
345EOF
346 CGI::h3("Error messages"), CGI::blockquote(CGI::pre($error)),
347 CGI::h3("Error context"), CGI::blockquote(CGI::pre($details));
348}
349
350sub warningOutput($$) {
351 my ($self, $warnings) = @_;
352
353 return
354 CGI::h2("Software Warnings"),
355 CGI::p(<<EOF),
356WeBWorK has encountered warnings while attempting to process this problem.
357It is likely that this indicates an error or ambiguity in the problem itself.
358If you are a student, contact your professor to have the problem corrected.
359If you are a professor, please consut the error output below for more informaiton.
360EOF
361 CGI::h3("Warning messages"),
362 CGI::blockquote(CGI::pre($warnings)),
363 ;
364}
365
304################################################################################ 366################################################################################
305# Generic versions of template escapes 367# Generic versions of template escapes
306################################################################################ 368################################################################################
307 369
308# Reminder: here are the template functions currently defined: 370# Reminder: here are the template functions currently defined:
309# 371#
372# head
310# path 373# path
311# style = text|image 374# style = text|image
312# image = URL of image 375# image = URL of image
313# text = text separator 376# text = text separator
377# loginstatus
314# links 378# links
315# siblings 379# siblings
316# nav 380# nav
317# style = text|image 381# style = text|image
318# imageprefix = prefix to image URL 382# imageprefix = prefix to image URL
… …
326 my $r = $self->{r}; 390 my $r = $self->{r};
327 $r->content_type('text/html'); 391 $r->content_type('text/html');
328 $r->send_http_header(); 392 $r->send_http_header();
329} 393}
330 394
395sub 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 my $exitURL = $r->uri() . "?user=$user&key=$key";
403 print CGI::small("Logged in as:", CGI::br(), "$user");
404 if ($user ne $eUser) {
405 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 }
412 return "";
413}
414
415# *** drunk code. rewrite.
416# also, this should be structured s.t. subclasses can add items to the links
417# area, i.e. "stacking"
331sub links { 418sub links {
332 my $self = shift; 419 my $self = shift;
333 my $ce = $self->{courseEnvironment}; 420 my $ce = $self->{courseEnvironment};
421 my $userName = $self->{r}->param("user");
422 my $courseName = $ce->{courseName};
334 my $root = $ce->{webworkURLs}->{root}; 423 my $root = $ce->{webworkURLs}->{root};
335 my $courseName = $ce->{courseName}; 424 my $permLevel = WeBWorK::DB::Auth->new($ce)->getPermissions($userName);
425 my $key = WeBWorK::DB::Auth->new($ce)->getKey($userName);
426 return "" unless defined $key;
427
428 # URLs to parts of the system
336 my $probSets = "$root/$courseName/?" . $self->url_authen_args(); 429 my $probSets = "$root/$courseName/?" . $self->url_authen_args();
337# my $prefs = "$root/prefs/?" . $self->url_authen_args(); 430 my $prefs = "$root/$courseName/options/?" . $self->url_authen_args();
431 my $prof = "$root/$courseName/prof/?" . $self->url_authen_args();
338# my $help = $ce->{webworkURLs}->{docs} . "?" . $self->url_authen_args(); 432 my $help = "$ce->{webworkURLs}->{docs}?" . $self->url_authen_args();
339 my $logout = "$root/$courseName/"; 433 my $logout = "$root/$courseName/logout/?" . $self->url_authen_args();
434
340 return 435 return
341 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(), 436 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(),
342# CGI::a({-href=>$prefs}, "User Options"), CGI::br(), 437 CGI::a({-href=>$prefs}, "User Options"), CGI::br(),
438 ($permLevel > 0
439 ? CGI::a({-href=>$prof}, "Professor") . CGI::br()
440 : ""),
343# CGI::a({-href=>$help}, "Help"), CGI::br(), 441 CGI::a({-href=>$help}, "Help"), CGI::br(),
344 CGI::a({-href=>$logout}, "Log Out"), CGI::br(), 442 CGI::a({-href=>$logout}, "Log Out"), CGI::br(),
345 ; 443 ;
346} 444}
347 445
348# This is different. It probably should print anything (except in debugging cases) 446# &if_can will return 1 if the current object->can("do $_[1]")
349# and it should return a boolean, not a string. &if is called in a nonstandard way 447sub if_can ($$) {
350# by &template, with $args as an arrayref instead of a hashref. this is a hack! yay!
351sub if {
352 my ($self, $args) = @_[0,-1]; 448 my ($self, $arg) = (@_);
353 # A single if "or"s it's components. Nesting produces "and".
354 449
355 my @args = @$args; # Hahahahaha, get it?! 450 if ($self->can("$arg")) {
356
357 if (@args % 2 != 0) {
358 # flip out and kill people, but do not commit seppuku
359 print '<!--&if recieved an uneven number of arguments. This shouldn\'t happen, but I\'ll let it slide.-->\n';
360 }
361
362 while (@args > 1) {
363 my ($key, $value) = (shift @args, shift @args);
364
365 if ($key eq "can" and $self->can($value)) {
366 return 1; 451 return 1;
367 } 452 } else {
368
369 # Other conditions go here, friend.
370 }
371
372 return 0; 453 return 0;
454 }
373} 455}
374 456
3751; 4571;
376 458
377__END__ 459__END__
Legend:
Removed from v.522  
changed lines
  Added in v.737
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9