Parent Directory
| 
Revision Log
Fixed glitch in links involving effective user --Mike
1 ################################################################################ 2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 3 # $Id$ 4 ################################################################################ 5 6 package WeBWorK::ContentGenerator; 7 8 =head1 NAME 9 10 WeBWorK::ContentGenerator - base class for modules that generate page content. 11 12 =cut 13 14 use strict; 15 use warnings; 16 use Apache::Constants qw(:common); 17 use CGI qw(); 18 use URI::Escape; 19 use WeBWorK::Authz; 20 use WeBWorK::DB; 21 use 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 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 # 37 sub new($$$$) { 38 my ($invocant, $r, $ce, $db) = @_; 39 my $class = ref($invocant) || $invocant; 40 my $self = { 41 r => $r, 42 ce => $ce, 43 db => $db, 44 authz => WeBWorK::Authz->new($r, $ce, $db), 45 noContent => undef, # false 46 }; 47 bless $self, $class; 48 return $self; 49 } 50 51 ################################################################################ 52 # Invocation and template processing 53 ################################################################################ 54 55 # go(@otherArguments) - render a page, using methods from the particular 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. 77 sub 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}, @_); 107 } 108 109 return $returnValue; 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 # 121 sub 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 # 178 sub 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($). 201 sub 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 222 return 0; 223 } 224 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 # 240 sub 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 262 sub 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 278 sub navMacro { 279 my $self = shift; 280 my %args = %{ shift() }; 281 my $tail = shift; 282 my @links = @_; 283 my $auth = $self->url_authen_args; 284 my $ce = $self->{ce}; 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; 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 # 310 sub 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 # 328 sub 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 # 337 sub 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 # 358 sub 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 # 369 sub 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 388 sub errorOutput($$$) { 389 my ($self, $error, $details) = @_; 390 return 391 CGI::h3("Software Error"), 392 CGI::p(<<EOF), 393 WeBWorK has encountered a software error while attempting to process this 394 problem. It is likely that there is an error in the problem itself. If you are 395 a student, contact your professor to have the error corrected. If you are a 396 professor, please consut the error output below for more informaiton. 397 EOF 398 CGI::h3("Error messages"), CGI::p(CGI::tt($error)), 399 CGI::h3("Error context"), CGI::p(CGI::tt($details)); 400 } 401 402 sub 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), 410 WeBWorK has encountered warnings while attempting to process this problem. It 411 is likely that this indicates an error or ambiguity in the problem itself. If 412 you are a student, contact your professor to have the problem corrected. If you 413 are a professor, please consut the warning output below for more informaiton. 414 EOF 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 443 sub header { 444 my $self = shift; 445 my $r = $self->{r}; 446 $r->content_type('text/html'); 447 $r->send_http_header(); 448 return OK; 449 } 450 451 sub 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" 474 sub 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; 485 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(); 491 492 return join("", 493 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(), 494 CGI::a({-href=>$prefs}, "User 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 } 502 sub 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 $userName = $self->{r}->param("effectiveUser"); 509 $userName = $self->{r}->param("user") unless defined $userName; 510 my ($set, $prob) = @components; 511 my $instructor = "$root/$courseName/instructor/?" . $self->url_authen_args(); 512 my $sets = "$root/$courseName/instructor/sets/?" . $self->url_authen_args(); 513 my $users = "$root/$courseName/instructor/users/?" . $self->url_authen_args(); 514 my $email = "$root/$courseName/instructor/send_mail/?" . $self->url_authen_args(); 515 my $statsRoot = "$root/$courseName/instructor/stats"; 516 my $stats = $statsRoot. '/?'.$self->url_authen_args(); 517 518 519 # Add direct links to sets e.g. 3:4 for set3 problem 4 520 my $setURL = (defined($set)) ? "$root/$courseName/instructor/sets/$set/?" . 521 $self->url_authen_args() : ''; 522 my $probURL = (defined($set) && defined($prob)) ? "$root/$courseName/instructor/pgProblemEditor/$set/$prob?" . 523 $self->url_authen_args() : ''; 524 my $setProb = ($setURL) ? CGI::a({-href=>$setURL},$set ) : ''; 525 526 $setProb .= ':'.CGI::a({-href=>$probURL},$prob) if $setProb && $probURL; 527 join("", 528 CGI::hr(), 529 CGI::a({-href=>$instructor}, "Instructor") , CGI::br(), 530 ' ',CGI::a({-href=>$sets}, "Set List") ,':', $setProb, CGI::br(), 531 ' ',CGI::a({-href=>$users}, "Class List") , CGI::br(), 532 ' ',CGI::a({-href=>$email}, "Send Email") , CGI::br(), 533 ' ',CGI::a({-href=>$stats}, 'Statistics'),CGI::br(), 534 (defined($set)) ? 535 ' '.CGI::a({-href=>"$statsRoot/set/$set/?".$self->url_authen_args}, "set:$set").CGI::br() 536 : '', 537 (defined($userName)) ? 538 ' '.CGI::a({-href=>"$statsRoot/student/$userName/?".$self->url_authen_args}, "$userName").CGI::br() 539 : '', 540 541 542 ) 543 544 } 545 # &if_can will return 1 if the current object->can("do $_[1]") 546 sub if_can ($$) { 547 my ($self, $arg) = (@_); 548 549 if ($self->can("$arg")) { 550 return 1; 551 } else { 552 return 0; 553 } 554 } 555 556 # Every content generator is logged in unless it says otherwise. 557 sub if_loggedin($$) { 558 my ($self, $arg) = (@_); 559 560 return $arg; 561 } 562 563 # Handling of errors in submissions 564 565 sub if_submiterror($$) { 566 my ($self, $arg) = @_; 567 if (exists $self->{submitError}) { 568 return $arg; 569 } else { 570 return !$arg; 571 } 572 } 573 574 sub submiterror { 575 my ($self) = @_; 576 if (exists $self->{submitError}) { 577 return $self->{submitError}; 578 } else { 579 return ""; 580 } 581 } 582 583 # General warning handling 584 585 sub if_warnings($$) { 586 my ($self, $arg) = @_; 587 return $self->{r}->notes("warnings") ? $arg : !$arg; 588 } 589 590 sub warnings { 591 my ($self) = @_; 592 my $r = $self->{r}; 593 if ($r->notes("warnings")) { 594 return $self->warningOutput($r->notes("warnings")); 595 } else { 596 return ""; 597 } 598 } 599 600 1; 601 602 __END__ 603 604 =head1 AUTHOR 605 606 Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu 607 and Sam Hathaway, sh002i (at) math.rochester.edu. 608 609 =cut
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |