[system] / branches / dg_dev / webwork2 / lib / WeBWorK.pm Repository:
ViewVC logotype

Diff of /branches/dg_dev/webwork2/lib/WeBWorK.pm

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

Revision 1835 Revision 1836
1################################################################################ 1################################################################################
2# WeBWorK Online Homework Delivery System 2# WeBWorK Online Homework Delivery System
3# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 3# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
4# $CVSHeader: webwork-modperl/lib/WeBWorK.pm,v 1.48 2004/02/14 00:54:56 sh002i Exp $ 4# $CVSHeader: webwork-modperl/lib/WeBWorK.pm,v 1.49 2004/02/21 10:15:58 toenail Exp $
5# 5#
6# This program is free software; you can redistribute it and/or modify it under 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 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 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. 9# version, or (b) the "Artistic License" which comes with this package.
… …
239 $courseID ($courseID) - list of sets 239 $courseID ($courseID) - list of sets
240 hardcopy (Hardcopy Generator) - generate hardcopy for user/set pairs 240 hardcopy (Hardcopy Generator) - generate hardcopy for user/set pairs
241 options (User Options) - change email address and password 241 options (User Options) - change email address and password
242 feedback (Feedback) - send feedback to professor via email 242 feedback (Feedback) - send feedback to professor via email
243 logout (Logout) - expire session and erase authentication tokens 243 logout (Logout) - expire session and erase authentication tokens
244 test (Test) - display request information
245 quiz_mode (Quiz) - "quiz" containing all problems from a set 244 quiz_mode (Quiz) - "quiz" containing all problems from a set
246 instructor (Instructor Tools) - main menu for instructor tools 245 instructor (Instructor Tools) - main menu for instructor tools
247 add_users (Add Users) - to be removed 246 add_users (Add Users) - add users to user list
247 assigner (Set Assigner) - assign sets to users
248 scoring (Scoring Tools) - generate scoring files for problem sets 248 scoring (Scoring Tools) - generate scoring files for problem sets
249 scoringDownload - send a scoring file to the client 249 scoringDownload - send a scoring file to the client
250 scoring_totals - ???
251 users (Users) - view/edit users 250 users (Users) - view/edit users
252 $userID ($userID) - user detail for given user 251 $userID ($userID) - user detail for given user
253 sets (Assigned Sets) - view/edit sets assigned to given user 252 sets (Assigned Sets) - view/edit sets assigned to given user
254 sets (Sets) - list of sets, add new sets, delete existing sets 253 sets (Sets) - list of sets, add new sets, delete existing sets
255 $setID - view/edit the given set 254 $setID - view/edit the given set
… …
286 } 285 }
287 elsif ($arg eq "logout") { 286 elsif ($arg eq "logout") {
288 $contentGenerator = "WeBWorK::ContentGenerator::Logout"; 287 $contentGenerator = "WeBWorK::ContentGenerator::Logout";
289 @arguments = (); 288 @arguments = ();
290 } 289 }
291 elsif ($arg eq "test") { 290 #elsif ($arg eq "test") {
292 $contentGenerator = "WeBWorK::ContentGenerator::Test"; 291 # $contentGenerator = "WeBWorK::ContentGenerator::Test";
293 @arguments = (); 292 # @arguments = ();
294 } 293 #}
295 elsif ($arg eq "quiz_mode" ) { 294 elsif ($arg eq "quiz_mode" ) {
296 $contentGenerator = "WeBWorK::ContentGenerator::GatewayQuiz"; 295 $contentGenerator = "WeBWorK::ContentGenerator::GatewayQuiz";
297 @arguments = @components; 296 @arguments = @components;
298 } 297 }
299 elsif ($arg eq "equation" ) { 298 elsif ($arg eq "equation" ) {
… …
317 } 316 }
318 elsif ($instructorArgument eq "scoring") { 317 elsif ($instructorArgument eq "scoring") {
319 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::Scoring"; 318 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::Scoring";
320 @arguments = (); 319 @arguments = ();
321 } 320 }
322# elsif ($instructorArgument eq "scoring_totals") {
323# $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ScoringTotals";
324# @arguments = ();
325# }
326 elsif ($instructorArgument eq "scoringDownload") { 321 elsif ($instructorArgument eq "scoringDownload") {
327 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ScoringDownload"; 322 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ScoringDownload";
328 @arguments = (); 323 @arguments = ();
329 } 324 }
330 elsif ($instructorArgument eq "users") { 325 elsif ($instructorArgument eq "users") {
… …
443 438
444 my $result; 439 my $result;
445 if ($contentGenerator) { 440 if ($contentGenerator) {
446 runtime_use($contentGenerator); 441 runtime_use($contentGenerator);
447 my $cg = $contentGenerator->new($r, $ce, $db); 442 my $cg = $contentGenerator->new($r, $ce, $db);
448 @arguments = () unless @arguments; 443 @arguments = () unless @arguments;
449 $WeBWorK::timer = WeBWorK::Timing->new("${contentGenerator}::go(@arguments)") if $timingON == 1; 444 $WeBWorK::timer = WeBWorK::Timing->new("${contentGenerator}::go(@arguments)") if $timingON == 1;
450 $WeBWorK::timer->start if $timingON == 1; 445 $WeBWorK::timer->start if $timingON == 1;
451 446
452 $result = $cg->go(@arguments); 447 $result = $cg->go(@arguments);
453 448
… …
466 return $result; 461 return $result;
467} 462}
468 463
469=back 464=back
470 465
466=head1 THE C<&dispatch_new> FUNCTION
467
468=cut
469
470use WeBWorK::Request;
471use WeBWorK::URLPath;
472
473use constant AUTHEN_MODULE => "WeBWorK::ContentGenerator::Login";
474
475sub debug(@) { print STDERR "dispatch_new: ", join("", @_) };
476
477sub dispatch_new($) {
478 my ($apache) = @_;
479 my $r = new WeBWorK::Request $apache;
480
481 my $method = $r->method;
482 my $location = $r->location;
483 my $uri = $r->uri;
484 my $path_info = $r->path_info | "";
485 my $args = $r->args || "";
486 my $webwork_root = $r->dir_config("webwork_root");
487 my $pg_root = $r->dir_config("pg_root");
488
489 #$r->send_http_header("text/html");
490
491 #print CGI::start_pre();
492
493 debug("Hi, I'm the new dispatcher!\n");
494 debug(("-" x 80) . "\n");
495
496 debug("Okay, I got some basic information:\n");
497 debug("The apache location is $location\n");
498 debug("The request method is $method\n");
499 debug("The URI is $uri\n");
500 debug("The path-info is $path_info\n");
501 debug("The argument string is $args\n");
502 debug("The WeBWorK root directory is $webwork_root\n");
503 debug("The PG root directory is $pg_root\n");
504 debug(("-" x 80) . "\n");
505
506 debug("The first thing we need to do is munge the path a little:\n");
507
508 my ($path) = $uri =~ m/$location(.*)/;
509 $path = "/" if $path eq ""; # no path at all
510
511 debug("We can't trust the path-info, so we make our own path.\n");
512 debug("path-info claims: $path_info\n");
513 debug("but it's really: $path\n");
514 debug("(if it's empty, we set it to \"/\".)\n");
515
516 $path =~ s|/+|/|g;
517 debug("...and here it is without repeated slashes: $path\n");
518
519 # lookbehind assertion for "not a slash"
520 # matches the boundary after the last char
521 $path =~ s|(?<=[^/])$|/|;
522 debug("...and here it is with a trailing slash: $path\n");
523
524 debug(("-" x 80) . "\n");
525
526 debug("Now we need to look at the path a little to figure out where we are\n");
527
528 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
529 my $urlPath = newFromPath WeBWorK::URLPath $path;
530 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
531
532 unless ($urlPath) {
533 debug("This path is invalid... see you later!\n");
534 return DECLINED;
535 }
536
537 my $displayModule = $urlPath->module;
538 my %displayArgs = $urlPath->args;
539
540 debug("The display module for this path is: $displayModule\n");
541 debug("...and here are the arguments we'll pass to it:\n");
542 foreach my $key (keys %displayArgs) {
543 debug("\t$key => $displayArgs{$key}\n");
544 }
545
546 unless ($displayModule) {
547 debug("The display module is empty, so we can DECLINE here.\n");
548 return DECLINED;
549 }
550
551 my $selfPath = $urlPath->path;
552 my $parent = $urlPath->parent;
553 my $parentPath = $parent ? $parent->path : "<no parent>";
554
555 debug("Reconstructing the original path gets us: $selfPath\n");
556 debug("And we can generate the path to our parent, too: $parentPath\n");
557 debug("(We could also figure out who our children are, but we'd need to supply additional arguments.)\n");
558 debug(("-" x 80) . "\n");
559
560 debug("Now we want to look at the parameters we got.\n");
561
562 debug("The raw params:\n");
563 foreach my $key ($r->param) {
564 debug("\t$key\n");
565 debug("\t\t$_\n") foreach $r->param($key);
566 }
567
568 mungeParams($r);
569
570 debug("The munged params:\n");
571 foreach my $key ($r->param) {
572 debug("\t$key\n");
573 debug("\t\t$_\n") foreach $r->param($key);
574 }
575
576 debug(("-" x 80) . "\n");
577
578 debug("We need to get a course environment (with or without a courseID!)\n");
579 my $ce = new WeBWorK::CourseEnvironment($webwork_root, $location, $pg_root, $displayArgs{courseID});
580 debug("Here's the course environment: $ce\n");
581
582 # FIXME: add upload handling here!
583
584 my ($db, $authz);
585
586 if ($displayArgs{courseID}) {
587 debug("We got a courseID from the URLPath, now we can do some stuff:\n");
588 debug("...we can create a database object...\n");
589 $db = new WeBWorK::DB($ce->{dbLayout});
590 debug("(here's the DB handle: $db)\n");
591
592 debug("...and we can authenticate the remote user...\n");
593 my $authen = new WeBWorK::Authen $r, $ce, $db;
594 my $authenOK = $authen->verify;
595 if ($authenOK) {
596 debug("Hi, ", $r->param("user"), ", glad you made it.\n");
597
598 debug("Authentication succeeded, so it makes sense to create an authz object...\n");
599 $authz = new WeBWorK::Authz $r, $ce, $db;
600 debug("(here's the authz object: $authz)\n");
601
602 debug("Now we deal with the effective user:\n");
603 my $userID = $r->param("user");
604 my $eUserID = $r->param("effectiveUser") || $userID;
605 debug("userID=$userID eUserID=$eUserID\n");
606 my $su_authorized = $authz->hasPermissions($userID, "become_student", $eUserID);
607 if ($su_authorized) {
608 debug("Ok, looks like you're is allowed to become $eUserID. Whoopie!\n");
609 } else {
610 debug("Uh oh, you're isn't allowed to become $eUserID. Nice try!\n");
611 $eUserID = $userID;
612 }
613 $r->param("effectiveUser" => $eUserID);
614 } else {
615 debug("Bad news: authentication failed!\n");
616 $displayModule = AUTHEN_MODULE;
617 debug("set displayModule to $displayModule\n");
618 }
619 }
620
621 debug("Now we add \$ce, \$db, \$authz, and \$urlPath to the WeBWorK::Request object.\n");
622 $r->ce($ce);
623 $r->db($db);
624 $r->authz($authz);
625 $r->urlpath($urlPath);
626
627 debug(("-" x 80) . "\n");
628 debug("Finally, we'll load the display module...\n");
629
630 runtime_use($displayModule);
631
632 debug("...instantiate it...\n");
633
634 # FIXME: change ContentGenerator interface to use WeBWorK::Request
635 my $instance = $displayModule->new($r);
636
637 debug("...and call it:\n");
638 debug("-------------------- call to ${displayModule}::go\n");
639 #print CGI::end_pre();
640
641 my $result = $instance->go();
642
643 #print CGI::start_pre();
644 debug("-------------------- call to ${displayModule}::go\n");
645 #print CGI::end_pre();
646
647 debug("returning result: $result\n");
648
649 return $result;
650}
651
652sub mungeParams {
653 my ($r) = @_;
654
655 my @paramQueue;
656
657 # remove all the params from the request, and store them in the param queue
658 foreach my $key ($r->param) {
659 push @paramQueue, [ $key => [ $r->param($key) ] ];
660 $r->parms->unset($key)
661 }
662
663 # exhaust the param queue, decoding encoded params
664 while (@paramQueue) {
665 my ($key, $values) = @{ shift @paramQueue };
666
667 if ($key =~ m/\,/) {
668 # we have multiple params encoded in a single param
669 # split them up and add them to the end of the queue
670 push @paramQueue, map { [ $_, $values ] } split m/\,/, $key;
671 } elsif ($key =~ m/\:/) {
672 # we have a whole param encoded in a key
673 # split it up and add it to the end of the queue
674 my ($newKey, $newValue) = split m/\:/, $key;
675 push @paramQueue, [ $newKey, [ $newValue ] ];
676 } else {
677 # this is a "normal" param
678 # add it to the param list
679 if (defined $r->param($key)) {
680 # the param already exists -- append the values we have
681 $r->param($key => [ $r->param($key), @$values ]);
682 } else {
683 # the param doesn't exist -- create it with the values we have
684 $r->param($key => $values);
685 }
686 }
687 }
688}
689
690
471=head1 AUTHOR 691=head1 AUTHOR
472 692
473Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam 693Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam
474Hathaway, sh002i at math.rochester.edu. 694Hathaway, sh002i at math.rochester.edu.
475 695
Legend:
Removed from v.1835  
changed lines
  Added in v.1836
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9