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