Parent Directory
| 
Revision Log
merging localization code and some (not all) of Grant's modifications
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/WeBWorK.pm,v 1.104 2010/05/15 18:44:26 gage 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; 18 19 =head1 NAME 20 21 WeBWorK - Dispatch requests to the appropriate content generator. 22 23 =head1 SYNOPSIS 24 25 my $r = Apache->request; 26 my $result = eval { WeBWorK::dispatch($r) }; 27 die "something bad happened: $@" if $@; 28 29 =head1 DESCRIPTION 30 31 C<WeBWorK> is the dispatcher for the WeBWorK system. Given an Apache request 32 object, it performs authentication and determines which subclass of 33 C<WeBWorK::ContentGenerator> to call. 34 35 =cut 36 37 BEGIN { $main::VERSION = "2.4.9"; } 38 39 use strict; 40 use warnings; 41 use Time::HiRes qw/time/; 42 use WeBWorK::Localize; 43 # load WeBWorK::Constants before anything else 44 # this sets package variables in several packages 45 use WeBWorK::Constants; 46 47 use WeBWorK::Authen; 48 use WeBWorK::Authz; 49 use WeBWorK::CourseEnvironment; 50 use WeBWorK::DB; 51 use WeBWorK::Debug; 52 use WeBWorK::Request; 53 use WeBWorK::Upload; 54 use WeBWorK::URLPath; 55 use WeBWorK::CGI; 56 use WeBWorK::Utils qw(runtime_use writeTimingLogEntry); 57 58 use mod_perl; 59 use constant MP2 => ( exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 ); 60 61 # Apache2 needs upload class 62 BEGIN { 63 if (MP2) { 64 require Apache2::Upload; 65 Apache2::Upload->import(); 66 require Apache2::RequestUtil; 67 Apache2::RequestUtil->import(); 68 } 69 } 70 71 use constant LOGIN_MODULE => "WeBWorK::ContentGenerator::Login"; 72 use constant PROCTOR_LOGIN_MODULE => "WeBWorK::ContentGenerator::LoginProctor"; 73 74 BEGIN { 75 # pre-compile all content generators 76 # Login and LoginProctor need to be handled separately, since they don't have paths 77 map { eval "require $_"; die $@ if $@ } 78 WeBWorK::URLPath->all_modules, 79 LOGIN_MODULE, 80 PROCTOR_LOGIN_MODULE; 81 # other candidates for preloading: 82 # - DB Record, Schema, and Driver classes (esp. Driver::SQL as it loads DBI) 83 # - CourseManagement subclasses (ditto. sql_single.pm) 84 # - WeBWorK::PG::Local, which loads WeBWorK::PG::Translator 85 # - Authen subclasses 86 } 87 88 our %SeedCE; 89 90 sub dispatch($) { 91 my ($apache) = @_; 92 my $r = WeBWorK::Request->new($apache); 93 94 my $method = $r->method; 95 my $location = $r->location; 96 my $uri = $r->uri; 97 my $path_info = $r->path_info | ""; 98 my $args = $r->args || ""; 99 my $dir_config = $r->dir_config; 100 my %conf_vars = map { $_ => $dir_config->{$_} } grep { /^webwork_/ } keys %$dir_config; 101 @SeedCE{keys %conf_vars} = values %conf_vars; 102 103 debug("\n\n===> Begin " . __PACKAGE__ . "::dispatch() <===\n\n"); 104 debug("Hi, I'm the new dispatcher!\n"); 105 debug(("-" x 80) . "\n"); 106 107 debug("Okay, I got some basic information:\n"); 108 debug("The apache location is $location\n"); 109 debug("The request method is $method\n"); 110 debug("The URI is $uri\n"); 111 debug("The path-info is $path_info\n"); 112 debug("The argument string is $args\n"); 113 #debug("The WeBWorK root directory is $webwork_root\n"); 114 #debug("The PG root directory is $pg_root\n"); 115 debug(("-" x 80) . "\n"); 116 117 debug("The first thing we need to do is munge the path a little:\n"); 118 119 ###################################################################### 120 # Create a URLPath object 121 ###################################################################### 122 my ($path) = $uri =~ m/$location(.*)/; 123 $path = "/" if $path eq ""; # no path at all 124 125 debug("We can't trust the path-info, so we make our own path.\n"); 126 debug("path-info claims: $path_info\n"); 127 debug("but it's really: $path\n"); 128 debug("(if it's empty, we set it to \"/\".)\n"); 129 130 $path =~ s|/+|/|g; 131 debug("...and here it is without repeated slashes: $path\n"); 132 133 # lookbehind assertion for "not a slash" 134 # matches the boundary after the last char 135 $path =~ s|(?<=[^/])$|/|; 136 debug("...and here it is with a trailing slash: $path\n"); 137 138 debug(("-" x 80) . "\n"); 139 140 debug("Now we need to look at the path a little to figure out where we are\n"); 141 142 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n"); 143 my $urlPath = WeBWorK::URLPath->newFromPath($path, $r); 144 # pointer to parent request for access to the $ce and language translation ability 145 # need to add this pointer whenever a new URLPath is created. 146 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n"); 147 148 unless ($urlPath) { 149 debug("This path is invalid... see you later!\n"); 150 die "The path '$path' is not valid.\n"; 151 } 152 153 my $displayModule = $urlPath->module; 154 my %displayArgs = $urlPath->args; 155 156 unless ($displayModule) { 157 debug("The display module is empty, so we can DECLINE here.\n"); 158 die "No display module found for path '$path'."; 159 } 160 161 debug("The display module for this path is: $displayModule\n"); 162 debug("...and here are the arguments we'll pass to it:\n"); 163 foreach my $key (keys %displayArgs) { 164 debug("\t$key => $displayArgs{$key}\n"); 165 } 166 167 my $selfPath = $urlPath->path; 168 my $parent = $urlPath->parent; 169 my $parentPath = $parent ? $parent->path : "<no parent>"; 170 171 debug("Reconstructing the original path gets us: $selfPath\n"); 172 debug("And we can generate the path to our parent, too: $parentPath\n"); 173 debug("(We could also figure out who our children are, but we'd need to supply additional arguments.)\n"); 174 debug(("-" x 80) . "\n"); 175 176 debug("The URLPath looks good, we'll add it to the request.\n"); 177 $r->urlpath($urlPath); 178 179 debug("Now we want to look at the parameters we got.\n"); 180 181 debug("The raw params:\n"); 182 foreach my $key ($r->param) { 183 my @vals = $r->param($key); 184 my $vals = join(", ", map { "'$_'" } @vals); 185 debug("\t$key => $vals\n"); 186 } 187 188 #mungeParams($r); 189 # 190 #debug("The munged params:\n"); 191 #foreach my $key ($r->param) { 192 # debug("\t$key\n"); 193 # debug("\t\t$_\n") foreach $r->param($key); 194 #} 195 196 debug(("-" x 80) . "\n"); 197 198 my $apache_hostname = $r->hostname; 199 my $apache_port = $r->get_server_port; 200 my $apache_is_ssl = ($r->subprocess_env('https') ? 1 : ""); 201 my $apache_root_url; 202 if ($apache_is_ssl) { 203 $apache_root_url = "https://$apache_hostname"; 204 $apache_root_url .= ":$apache_port" if $apache_port != 443; 205 } else { 206 $apache_root_url = "http://$apache_hostname"; 207 $apache_root_url .= ":$apache_port" if $apache_port != 80; 208 } 209 210 211 #################################################################### 212 # Create Course Environment $ce 213 #################################################################### 214 debug("We need to get a course environment (with or without a courseID!)\n"); 215 my $ce = eval { new WeBWorK::CourseEnvironment({ 216 %SeedCE, 217 courseName => $displayArgs{courseID}, 218 # this is kind of a hack, but it's really the only sane way to get this 219 # server information into the PG box 220 apache_hostname => $apache_hostname, 221 apache_port => $apache_port, 222 apache_is_ssl => $apache_is_ssl, 223 apache_root_url => $apache_root_url, 224 }) }; 225 $@ and die "Failed to initialize course environment: $@\n"; 226 debug("Here's the course environment: $ce\n"); 227 $r->ce($ce); 228 229 230 ###################### 231 # Localizing language 232 ###################### 233 my $language= $ce->{language} || "en"; 234 $r->language_handle(WeBWorK::Localize->get_handle($language) ); 235 236 my @uploads; 237 if (MP2) { 238 my $upload_table = $r->upload; 239 @uploads = values %$upload_table if defined $upload_table; 240 } else { 241 @uploads = $r->upload; 242 } 243 foreach my $u (@uploads) { 244 # make sure it's a "real" upload 245 next unless $u->filename; 246 247 # store the upload 248 my $upload = WeBWorK::Upload->store($u, 249 dir => $ce->{webworkDirs}->{uploadCache} 250 ); 251 252 # store the upload ID and hash in the file upload field 253 my $id = $upload->id; 254 my $hash = $upload->hash; 255 $r->param($u->name => "$id $hash"); 256 } 257 258 # create these out here. they should fail if they don't have the right information 259 # this lets us not be so careful about whether these objects are defined when we use them. 260 # instead, we just create the behavior that if they don't have a valid $db they fail. 261 my $authz = new WeBWorK::Authz($r); 262 $r->authz($authz); 263 264 # figure out which authentication modules to use 265 #my $user_authen_module; 266 #my $proctor_authen_module; 267 #if (ref $ce->{authen}{user_module} eq "HASH") { 268 # if (exists $ce->{authen}{user_module}{$ce->{dbLayoutName}}) { 269 # $user_authen_module = $ce->{authen}{user_module}{$ce->{dbLayoutName}}; 270 # } else { 271 # $user_authen_module = $ce->{authen}{user_module}{"*"}; 272 # } 273 #} else { 274 # $user_authen_module = $ce->{authen}{user_module}; 275 #} 276 #if (ref $ce->{authen}{proctor_module} eq "HASH") { 277 # if (exists $ce->{authen}{proctor_module}{$ce->{dbLayoutName}}) { 278 # $proctor_authen_module = $ce->{authen}{proctor_module}{$ce->{dbLayoutName}}; 279 # } else { 280 # $proctor_authen_module = $ce->{authen}{proctor_module}{"*"}; 281 # } 282 #} else { 283 # $proctor_authen_module = $ce->{authen}{proctor_module}; 284 #} 285 286 my $user_authen_module = WeBWorK::Authen::class($ce, "user_module"); 287 288 runtime_use $user_authen_module; 289 my $authen = $user_authen_module->new($r); 290 debug("Using user_authen_module $user_authen_module: $authen\n"); 291 $r->authen($authen); 292 293 my $db; 294 295 if ($displayArgs{courseID}) { 296 debug("We got a courseID from the URLPath, now we can do some stuff:\n"); 297 298 unless (-e $ce->{courseDirs}->{root}) { 299 die "Course '$displayArgs{courseID}' not found: $!"; 300 } 301 302 debug("...we can create a database object...\n"); 303 $db = new WeBWorK::DB($ce->{dbLayout}); 304 debug("(here's the DB handle: $db)\n"); 305 $r->db($db); 306 307 my $authenOK = $authen->verify; 308 if ($authenOK) { 309 my $userID = $r->param("user"); 310 debug("Hi, $userID, glad you made it.\n"); 311 312 # tell authorizer to cache this user's permission level 313 $authz->setCachedUser($userID); 314 315 debug("Now we deal with the effective user:\n"); 316 my $eUserID = $r->param("effectiveUser") || $userID; 317 debug("userID=$userID eUserID=$eUserID\n"); 318 if ($userID ne $eUserID) { 319 debug("userID and eUserID differ... seeing if userID has 'become_student' permission.\n"); 320 my $su_authorized = $authz->hasPermissions($userID, "become_student"); 321 if ($su_authorized) { 322 debug("Ok, looks like you're allowed to become $eUserID. Whoopie!\n"); 323 } else { 324 debug("Uh oh, you're not allowed to become $eUserID. Nice try!\n"); 325 die "You are not allowed to act as another user.\n"; 326 } 327 } 328 329 # set effectiveUser in case it was changed or not set to begin with 330 $r->param("effectiveUser" => $eUserID); 331 332 # if we're doing a proctored test, after the user has been authenticated 333 # we need to also check on the proctor. note that in the gateway quiz 334 # module we double check this, to be sure that someone isn't taking a 335 # proctored quiz but calling the unproctored ContentGenerator 336 my $urlProducedPath = $urlPath->path(); 337 if ( $urlProducedPath =~ /proctored_quiz_mode/i ) { 338 my $proctor_authen_module = WeBWorK::Authen::class($ce, "proctor_module"); 339 runtime_use $proctor_authen_module; 340 my $authenProctor = $proctor_authen_module->new($r); 341 debug("Using proctor_authen_module $proctor_authen_module: $authenProctor\n"); 342 my $procAuthOK = $authenProctor->verify(); 343 344 if (not $procAuthOK) { 345 $displayModule = PROCTOR_LOGIN_MODULE; 346 } 347 } 348 } else { 349 debug("Bad news: authentication failed!\n"); 350 $displayModule = LOGIN_MODULE; 351 debug("set displayModule to $displayModule\n"); 352 } 353 } 354 355 # store the time before we invoke the content generator 356 my $cg_start = time; # this is Time::HiRes's time, which gives floating point values 357 358 debug(("-" x 80) . "\n"); 359 debug("Finally, we'll load the display module...\n"); 360 361 runtime_use($displayModule); 362 363 debug("...instantiate it...\n"); 364 365 my $instance = $displayModule->new($r); 366 367 debug("...and call it:\n"); 368 debug("-------------------- call to ${displayModule}::go\n"); 369 370 my $result = $instance->go(); 371 372 debug("-------------------- call to ${displayModule}::go\n"); 373 374 my $cg_end = time; 375 my $cg_duration = $cg_end - $cg_start; 376 writeTimingLogEntry($ce, "[".$r->uri."]", sprintf("runTime = %.3f sec", $cg_duration)." ".$ce->{dbLayoutName}, ""); 377 378 debug("returning result: " . (defined $result ? $result : "UNDEF") . "\n"); 379 #@LimitedPolynomial::BOP::ISA; #FIXME this is needed to zero out 380 #@LimitedPolynomial::UOP::ISA; 381 #\@LimitedPolynomial::BOP::ISA and prevent error messages of the form 382 #[Sat May 15 14:23:08 2010] [warn] [client 127.0.0.1] [/webwork2/gage_course/test_set/6/] 383 #Can't locate package LimitedPolynomial::BOP for @LimitedPolynomial::BOP::add::ISA at /opt/webwork/webwork2/lib/Apache/WeBWorK.pm line 115., referer: http://localhost/webwork2/gage_course/test_set/6/ no one knows why 384 return $result; 385 } 386 387 sub mungeParams { 388 my ($r) = @_; 389 390 my @paramQueue; 391 392 # remove all the params from the request, and store them in the param queue 393 foreach my $key ($r->param) { 394 push @paramQueue, [ $key => [ $r->param($key) ] ]; 395 $r->parms->unset($key) 396 } 397 398 # exhaust the param queue, decoding encoded params 399 while (@paramQueue) { 400 my ($key, $values) = @{ shift @paramQueue }; 401 402 if ($key =~ m/\,/) { 403 # we have multiple params encoded in a single param 404 # split them up and add them to the end of the queue 405 push @paramQueue, map { [ $_, $values ] } split m/\,/, $key; 406 } elsif ($key =~ m/\:/) { 407 # we have a whole param encoded in a key 408 # split it up and add it to the end of the queue 409 my ($newKey, $newValue) = split m/\:/, $key; 410 push @paramQueue, [ $newKey, [ $newValue ] ]; 411 } else { 412 # this is a "normal" param 413 # add it to the param list 414 if (defined $r->param($key)) { 415 # the param already exists -- append the values we have 416 $r->param($key => [ $r->param($key), @$values ]); 417 } else { 418 # the param doesn't exist -- create it with the values we have 419 $r->param($key => $values); 420 } 421 } 422 } 423 } 424 425 426 # labeled_input subroutine 427 # 428 # Creates a form input element with a label added to the correct place. 429 # Takes in up to six parameters: 430 # 431 # -type (type of input element), -name (name of input element), -id (id of the input element), -value (value of the input element), -label_text (the text on the label), -label_id (the id of the label) 432 # 433 # If any of the parameters are not specified, they default to "none". 434 # 435 # UPDATE: updated lable tags so that their "for" property will point to the id of the element that they are labeling. This means that entering an id for the input element becomes essentially mandatory if you want the tag to work correctly. 436 437 # DEPRECATED - see below 438 439 # sub labeled_input 440 # { 441 # my %param = (-type=>"none", -name=>"none", -value=>"none", -id=>"none", -label_text=>"none", -label_id=>"none", @_); 442 443 # if($param{-type} eq "text" or $param{-type} eq "password" or $param{-type} eq "file"){ 444 # return CGI::label({-id=>$param{-label_id}, -for=>$param{-id}},$param{-label_text}).CGI::input({-type=>$param{-type}, -name=>$param{-name}, -value=>$param{-value}, -id=>$param{-id}}).CGI::br(); 445 # } 446 # elsif($param{-type} eq "checkbox" or $param{-type} eq "radio"){ 447 # return CGI::input({-type=>$param{-type}, -name=>$param{-name}, -value=>$param{-value}, -id=>$param{-id}}).CGI::label({-id=>$param{-label_id}, -for=>$param{-id}},$param{-label_text}).CGI::br(); 448 # } 449 # elsif($param{-type} eq "submit" or $param{-type} eq "button" or $param{-type} eq "reset"){ 450 # return CGI::input({-type=>$param{-type}, -name=>$param{-name}, -value=>$param{-value}, -id=>$param{-id}}).CGI::br(); 451 # } 452 # else{ 453 # return "Not a valid input type"; 454 # } 455 # } 456 457 458 # CGI_labeled_input subroutine 459 460 # A replacement to the labeled_input subroutine above, created when it was determined that the old subroutine was limited in that it did not allow for attributes other than the ones that it specified. 461 462 # This subroutine rectifies that problem by taking in attributes for the input elements and label elements as hashes and simply entering them into the CGI routines, which already support attributes as hash parameters. 463 464 # The way it attaches label tags is similar to the labeled_input subroutine. 465 466 # This subroutine has also been expanded to be able to handle select elements. 467 468 # Five parameters are taken in as a hash: -type (specifying the type of the input element), -id (specifying the id of the input element), -label_text (specifying the text to go in the label), -input_attr (a hash specifying any additional attributes for the input element, if any), and -label_attr (a hash specifying additional attributes for the label element, if any). 469 470 # As before, all parameters are optional, with the scalar parameters defaulting to "none" and the hash parameters defaulting to empty. 471 472 473 sub CGI_labeled_input 474 { 475 my %param = (-type=>"none", -id=>"none", -label_text=>"none", -input_attr=>{}, -label_attr=>{}, @_); 476 477 $param{-input_attr}{-type} = $param{-type}; 478 $param{-input_attr}{-id} = $param{-id}; 479 $param{-label_attr}{-for} = $param{-id}; 480 481 if($param{-type} eq "text" or $param{-type} eq "password" or $param{-type} eq "file"){ 482 return CGI::label($param{-label_attr},$param{-label_text}).CGI::input($param{-input_attr}); 483 } 484 elsif($param{-type} eq "checkbox" or $param{-type} eq "radio"){ 485 return CGI::input($param{-input_attr}).CGI::label($param{-label_attr},$param{-label_text}); 486 } 487 elsif($param{-type} eq "submit" or $param{-type} eq "button" or $param{-type} eq "reset"){ 488 return CGI::input($param{-input_attr}); 489 } 490 elsif($param{-type} eq "select"){ 491 return CGI::label($param{-label_attr},$param{-label_text}).CGI::popup_menu($param{-input_attr}); 492 } 493 elsif($param{-type} eq "textarea"){ 494 return CGI::label($param{-label_attr},$param{-label_text}).CGI::br().CGI::br().CGI::textarea($param{-input_attr}); 495 } 496 else{ 497 "Not a valid input type"; 498 } 499 } 500 501 # split_cap subroutine - ghe3 502 503 # A sort of wrapper for the built-in split function which uses capital letters as a delimiter, and returns a string containing the separated substrings separated by a whitespace. Used to make actionID's more readable. 504 505 sub split_cap 506 { 507 my $str = shift; 508 509 my @str_arr = split(//,$str); 510 my $count = scalar(@str_arr); 511 512 my $i = 0; 513 my $prev = 0; 514 my @result = (); 515 my $hasCapital = 0; 516 foreach(@str_arr){ 517 if($_ =~ /[A-Z]/){ 518 $hasCapital = 1; 519 push(@result, join("", @str_arr[$prev..$i-1])); 520 $prev = $i; 521 } 522 $i++; 523 } 524 525 unless($hasCapital){ 526 return $str; 527 } 528 else{ 529 push(@result, join("", @str_arr[$prev..$count-1])); 530 return join(" ",@result); 531 } 532 } 533 534 # underscore_to_whitespace subroutine 535 536 # a simple subroutine for converting underscores in a given string to whitespace 537 538 sub underscore_to_whitespace{ 539 my $str = shift; 540 541 my @strArr = split("",$str); 542 foreach(@strArr){ 543 if($_ eq "_"){ 544 $_ = " " 545 } 546 } 547 548 my $result = join("",@strArr); 549 550 return $result; 551 } 552 553 sub remove_duplicates{ 554 my @arr = @_; 555 556 my %unique; 557 my @result; 558 559 foreach(@arr){ 560 if(defined $unique{$_}){ 561 next; 562 } 563 else{ 564 push(@result, $_); 565 $unique{$_} = "seen"; 566 } 567 } 568 569 return @result; 570 571 } 572 573 =head1 AUTHOR 574 575 Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam 576 Hathaway, sh002i at math.rochester.edu. 577 578 =cut 579 580 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |