Parent Directory
| 
Revision Log
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 $r->language_handle( WeBWorK::Localize::getLoc($language) ); 236 237 my @uploads; 238 if (MP2) { 239 my $upload_table = $r->upload; 240 @uploads = values %$upload_table if defined $upload_table; 241 } else { 242 @uploads = $r->upload; 243 } 244 foreach my $u (@uploads) { 245 # make sure it's a "real" upload 246 next unless $u->filename; 247 248 # store the upload 249 my $upload = WeBWorK::Upload->store($u, 250 dir => $ce->{webworkDirs}->{uploadCache} 251 ); 252 253 # store the upload ID and hash in the file upload field 254 my $id = $upload->id; 255 my $hash = $upload->hash; 256 $r->param($u->name => "$id $hash"); 257 } 258 259 # create these out here. they should fail if they don't have the right information 260 # this lets us not be so careful about whether these objects are defined when we use them. 261 # instead, we just create the behavior that if they don't have a valid $db they fail. 262 my $authz = new WeBWorK::Authz($r); 263 $r->authz($authz); 264 265 # figure out which authentication modules to use 266 #my $user_authen_module; 267 #my $proctor_authen_module; 268 #if (ref $ce->{authen}{user_module} eq "HASH") { 269 # if (exists $ce->{authen}{user_module}{$ce->{dbLayoutName}}) { 270 # $user_authen_module = $ce->{authen}{user_module}{$ce->{dbLayoutName}}; 271 # } else { 272 # $user_authen_module = $ce->{authen}{user_module}{"*"}; 273 # } 274 #} else { 275 # $user_authen_module = $ce->{authen}{user_module}; 276 #} 277 #if (ref $ce->{authen}{proctor_module} eq "HASH") { 278 # if (exists $ce->{authen}{proctor_module}{$ce->{dbLayoutName}}) { 279 # $proctor_authen_module = $ce->{authen}{proctor_module}{$ce->{dbLayoutName}}; 280 # } else { 281 # $proctor_authen_module = $ce->{authen}{proctor_module}{"*"}; 282 # } 283 #} else { 284 # $proctor_authen_module = $ce->{authen}{proctor_module}; 285 #} 286 287 my $user_authen_module = WeBWorK::Authen::class($ce, "user_module"); 288 289 runtime_use $user_authen_module; 290 my $authen = $user_authen_module->new($r); 291 debug("Using user_authen_module $user_authen_module: $authen\n"); 292 $r->authen($authen); 293 294 my $db; 295 296 if ($displayArgs{courseID}) { 297 debug("We got a courseID from the URLPath, now we can do some stuff:\n"); 298 299 unless (-e $ce->{courseDirs}->{root}) { 300 die "Course '$displayArgs{courseID}' not found: $!"; 301 } 302 303 debug("...we can create a database object...\n"); 304 $db = new WeBWorK::DB($ce->{dbLayout}); 305 debug("(here's the DB handle: $db)\n"); 306 $r->db($db); 307 308 my $authenOK = $authen->verify; 309 if ($authenOK) { 310 my $userID = $r->param("user"); 311 debug("Hi, $userID, glad you made it.\n"); 312 313 # tell authorizer to cache this user's permission level 314 $authz->setCachedUser($userID); 315 316 debug("Now we deal with the effective user:\n"); 317 my $eUserID = $r->param("effectiveUser") || $userID; 318 debug("userID=$userID eUserID=$eUserID\n"); 319 if ($userID ne $eUserID) { 320 debug("userID and eUserID differ... seeing if userID has 'become_student' permission.\n"); 321 my $su_authorized = $authz->hasPermissions($userID, "become_student"); 322 if ($su_authorized) { 323 debug("Ok, looks like you're allowed to become $eUserID. Whoopie!\n"); 324 } else { 325 debug("Uh oh, you're not allowed to become $eUserID. Nice try!\n"); 326 die "You are not allowed to act as another user.\n"; 327 } 328 } 329 330 # set effectiveUser in case it was changed or not set to begin with 331 $r->param("effectiveUser" => $eUserID); 332 333 # if we're doing a proctored test, after the user has been authenticated 334 # we need to also check on the proctor. note that in the gateway quiz 335 # module we double check this, to be sure that someone isn't taking a 336 # proctored quiz but calling the unproctored ContentGenerator 337 my $urlProducedPath = $urlPath->path(); 338 if ( $urlProducedPath =~ /proctored_quiz_mode/i ) { 339 my $proctor_authen_module = WeBWorK::Authen::class($ce, "proctor_module"); 340 runtime_use $proctor_authen_module; 341 my $authenProctor = $proctor_authen_module->new($r); 342 debug("Using proctor_authen_module $proctor_authen_module: $authenProctor\n"); 343 my $procAuthOK = $authenProctor->verify(); 344 345 if (not $procAuthOK) { 346 $displayModule = PROCTOR_LOGIN_MODULE; 347 } 348 } 349 } else { 350 debug("Bad news: authentication failed!\n"); 351 $displayModule = LOGIN_MODULE; 352 debug("set displayModule to $displayModule\n"); 353 } 354 } 355 356 # store the time before we invoke the content generator 357 my $cg_start = time; # this is Time::HiRes's time, which gives floating point values 358 359 debug(("-" x 80) . "\n"); 360 debug("Finally, we'll load the display module...\n"); 361 362 runtime_use($displayModule); 363 364 debug("...instantiate it...\n"); 365 366 my $instance = $displayModule->new($r); 367 368 debug("...and call it:\n"); 369 debug("-------------------- call to ${displayModule}::go\n"); 370 371 my $result = $instance->go(); 372 373 debug("-------------------- call to ${displayModule}::go\n"); 374 375 my $cg_end = time; 376 my $cg_duration = $cg_end - $cg_start; 377 writeTimingLogEntry($ce, "[".$r->uri."]", sprintf("runTime = %.3f sec", $cg_duration)." ".$ce->{dbLayoutName}, ""); 378 379 debug("returning result: " . (defined $result ? $result : "UNDEF") . "\n"); 380 #@LimitedPolynomial::BOP::ISA; #FIXME this is needed to zero out 381 #@LimitedPolynomial::UOP::ISA; 382 #\@LimitedPolynomial::BOP::ISA and prevent error messages of the form 383 #[Sat May 15 14:23:08 2010] [warn] [client 127.0.0.1] [/webwork2/gage_course/test_set/6/] 384 #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 385 return $result; 386 } 387 388 sub mungeParams { 389 my ($r) = @_; 390 391 my @paramQueue; 392 393 # remove all the params from the request, and store them in the param queue 394 foreach my $key ($r->param) { 395 push @paramQueue, [ $key => [ $r->param($key) ] ]; 396 $r->parms->unset($key) 397 } 398 399 # exhaust the param queue, decoding encoded params 400 while (@paramQueue) { 401 my ($key, $values) = @{ shift @paramQueue }; 402 403 if ($key =~ m/\,/) { 404 # we have multiple params encoded in a single param 405 # split them up and add them to the end of the queue 406 push @paramQueue, map { [ $_, $values ] } split m/\,/, $key; 407 } elsif ($key =~ m/\:/) { 408 # we have a whole param encoded in a key 409 # split it up and add it to the end of the queue 410 my ($newKey, $newValue) = split m/\:/, $key; 411 push @paramQueue, [ $newKey, [ $newValue ] ]; 412 } else { 413 # this is a "normal" param 414 # add it to the param list 415 if (defined $r->param($key)) { 416 # the param already exists -- append the values we have 417 $r->param($key => [ $r->param($key), @$values ]); 418 } else { 419 # the param doesn't exist -- create it with the values we have 420 $r->param($key => $values); 421 } 422 } 423 } 424 } 425 426 427 # labeled_input subroutine 428 # 429 # Creates a form input element with a label added to the correct place. 430 # Takes in up to six parameters: 431 # 432 # -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) 433 # 434 # If any of the parameters are not specified, they default to "none". 435 # 436 # 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. 437 438 # DEPRECATED - see below 439 440 # sub labeled_input 441 # { 442 # my %param = (-type=>"none", -name=>"none", -value=>"none", -id=>"none", -label_text=>"none", -label_id=>"none", @_); 443 444 # if($param{-type} eq "text" or $param{-type} eq "password" or $param{-type} eq "file"){ 445 # 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(); 446 # } 447 # elsif($param{-type} eq "checkbox" or $param{-type} eq "radio"){ 448 # 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(); 449 # } 450 # elsif($param{-type} eq "submit" or $param{-type} eq "button" or $param{-type} eq "reset"){ 451 # return CGI::input({-type=>$param{-type}, -name=>$param{-name}, -value=>$param{-value}, -id=>$param{-id}}).CGI::br(); 452 # } 453 # else{ 454 # return "Not a valid input type"; 455 # } 456 # } 457 458 459 # CGI_labeled_input subroutine 460 461 # 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. 462 463 # 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. 464 465 # The way it attaches label tags is similar to the labeled_input subroutine. 466 467 # This subroutine has also been expanded to be able to handle select elements. 468 469 # 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). 470 471 # As before, all parameters are optional, with the scalar parameters defaulting to "none" and the hash parameters defaulting to empty. 472 473 474 sub CGI_labeled_input 475 { 476 my %param = (-type=>"none", -id=>"none", -label_text=>"none", -input_attr=>{}, -label_attr=>{}, @_); 477 478 $param{-input_attr}{-type} = $param{-type}; 479 $param{-input_attr}{-id} = $param{-id}; 480 $param{-label_attr}{-for} = $param{-id}; 481 482 if($param{-type} eq "text" or $param{-type} eq "password" or $param{-type} eq "file"){ 483 return CGI::label($param{-label_attr},$param{-label_text}).CGI::input($param{-input_attr}); 484 } 485 elsif($param{-type} eq "checkbox" or $param{-type} eq "radio"){ 486 return CGI::input($param{-input_attr}).CGI::label($param{-label_attr},$param{-label_text}); 487 } 488 elsif($param{-type} eq "submit" or $param{-type} eq "button" or $param{-type} eq "reset"){ 489 return CGI::input($param{-input_attr}); 490 } 491 elsif($param{-type} eq "select"){ 492 return CGI::label($param{-label_attr},$param{-label_text}).CGI::popup_menu($param{-input_attr}); 493 } 494 elsif($param{-type} eq "textarea"){ 495 return CGI::label($param{-label_attr},$param{-label_text}).CGI::br().CGI::br().CGI::textarea($param{-input_attr}); 496 } 497 else{ 498 "Not a valid input type"; 499 } 500 } 501 502 # split_cap subroutine - ghe3 503 504 # 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. 505 506 sub split_cap 507 { 508 my $str = shift; 509 510 my @str_arr = split(//,$str); 511 my $count = scalar(@str_arr); 512 513 my $i = 0; 514 my $prev = 0; 515 my @result = (); 516 my $hasCapital = 0; 517 foreach(@str_arr){ 518 if($_ =~ /[A-Z]/){ 519 $hasCapital = 1; 520 push(@result, join("", @str_arr[$prev..$i-1])); 521 $prev = $i; 522 } 523 $i++; 524 } 525 526 unless($hasCapital){ 527 return $str; 528 } 529 else{ 530 push(@result, join("", @str_arr[$prev..$count-1])); 531 return join(" ",@result); 532 } 533 } 534 535 # underscore_to_whitespace subroutine 536 537 # a simple subroutine for converting underscores in a given string to whitespace 538 539 sub underscore_to_whitespace{ 540 my $str = shift; 541 542 my @strArr = split("",$str); 543 foreach(@strArr){ 544 if($_ eq "_"){ 545 $_ = " " 546 } 547 } 548 549 my $result = join("",@strArr); 550 551 return $result; 552 } 553 554 sub remove_duplicates{ 555 my @arr = @_; 556 557 my %unique; 558 my @result; 559 560 foreach(@arr){ 561 if(defined $unique{$_}){ 562 next; 563 } 564 else{ 565 push(@result, $_); 566 $unique{$_} = "seen"; 567 } 568 } 569 570 return @result; 571 572 } 573 574 =head1 AUTHOR 575 576 Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam 577 Hathaway, sh002i at math.rochester.edu. 578 579 =cut 580 581 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |