Parent Directory
| 
Revision Log
backport (sh002i): disable test CG
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader$ 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::URLPath; 18 19 =head1 NAME 20 21 WeBWorK::URLPath - the WeBWorK virtual URL heirarchy. 22 23 =cut 24 25 use strict; 26 use warnings; 27 use Carp; 28 use WeBWorK::Debug; 29 30 { 31 no warnings "redefine"; 32 33 sub debug { 34 my ($label, $indent, @message) = @_; 35 my $header = " "x$indent; 36 $header .= "$label: " if $label ne ""; 37 WeBWorK::Debug::debug($header, @message); 38 } 39 } 40 41 =head1 VIRTUAL HEIRARCHY 42 43 PLEASE FOR THE LOVE OF GOD UPDATE THIS IF YOU CHANGE THE HEIRARCHY BELOW!!! 44 45 root / 46 47 course_admin /admin/ -> logout, options, instructor_tools 48 set_list /$courseID/ 49 50 equation_display /$courseID/equation/ 51 feedback /$courseID/feedback/ 52 gateway_quiz /$courseID/quiz_mode/$setID/ 53 proctored_gateway_quiz /$courseID/proctored_quiz_mode/$setID/ 54 proctored_gateway_proctor_login /$courseID/proctored_quiz_mode/$setID/proctor_login/ 55 grades /$courseID/grades/ 56 hardcopy /$courseID/hardcopy/ 57 hardcopy_preselect_set /$courseID/hardcopy/$setID/ 58 logout /$courseID/logout/ 59 options /$courseID/options/ 60 #test /$courseID/test/ 61 62 instructor_tools /$courseID/instructor/ 63 64 instructor_user_list /$courseID/instructor/users/ 65 instructor_user_detail /$courseID/instructor/users/$userID/ 66 instructor_sets_assigned_to_user /$courseID/instructor/users/$userID/sets/ 67 68 instructor_set_list /$courseID/instructor/sets/ 69 instructor_set_detail /$courseID/instructor/sets/$setID/ 70 instructor_users_assigned_to_set /$courseID/instructor/sets/$setID/users/ 71 72 instructor_add_users /$courseID/instructor/add_users/ 73 instructor_set_assigner /$courseID/instructor/assigner/ 74 instructor_file_transfer /$courseID/instructor/files/ 75 instructor_file_manager /$courseID/instructor/file_manager/ 76 instructor_set_maker /$courseID/instructor/setmaker/ 77 instructor_config /$courseID/instructor/config/ 78 instructor_compare /$courseID/instructor/compare/ 79 80 instructor_problem_editor /$courseID/instructor/pgProblemEditor/ 81 instructor_problem_editor_withset /$courseID/instructor/pgProblemEditor/$setID/ 82 instructor_problem_editor_withset_withproblem 83 /$courseID/instructor/pgProblemEditor/$setID/$problemID/ 84 85 instructor_scoring /$courseID/instructor/scoring/ 86 instructor_scoring_download /$courseID/instructor/scoringDownload/ 87 instructor_mail_merge /$courseID/instructor/send_mail/ 88 instructor_answer_log /$courseID/instructor/show_answers/ 89 instructor_preflight /$courseID/instructor/preflight/ 90 91 instructor_statistics /$courseID/instructor/stats/ 92 instructor_set_statistics /$courseID/instructor/stats/set/$setID/ 93 instructor_user_statistics /$courseID/instructor/stats/student/$userID/ 94 95 instructor_progress /$courseID/instructor/StudentProgress/ 96 instructor_set_progress /$courseID/instructor/StudentProgress/set/$setID/ 97 instructor_user_progress /$courseID/instructor/StudentProgress/student/$userID/ 98 99 problem_list /$courseID/$setID/ 100 problem_detail /$courseID/$setID/$problemID/ 101 102 =cut 103 104 ################################################################################ 105 # tree of path types 106 ################################################################################ 107 108 our %pathTypes = ( 109 root => { 110 name => 'WeBWorK', 111 parent => '', 112 kids => [ qw/course_admin set_list/ ], 113 match => qr|^/|, 114 capture => [ qw// ], 115 produce => '/', 116 display => 'WeBWorK::ContentGenerator::Home', 117 }, 118 course_admin => { 119 name => 'Course Administration', 120 parent => 'root', 121 kids => [ qw/logout options instructor_tools/ ], 122 match => qr|^(admin)/|, 123 capture => [ qw/courseID/ ], 124 produce => 'admin/', 125 display => 'WeBWorK::ContentGenerator::CourseAdmin', 126 }, 127 128 ################################################################################ 129 130 set_list => { 131 name => '$courseID', 132 parent => 'root', 133 kids => [ qw/equation_display feedback gateway_quiz proctored_gateway_quiz grades hardcopy 134 logout options instructor_tools problem_list 135 / ], 136 match => qr|^([^/]+)/|, 137 capture => [ qw/courseID/ ], 138 produce => '$courseID/', 139 display => 'WeBWorK::ContentGenerator::ProblemSets', 140 }, 141 142 ################################################################################ 143 144 equation_display => { 145 name => 'Equation Display', 146 parent => 'set_list', 147 kids => [ qw// ], 148 match => qr|^equation/|, 149 capture => [ qw// ], 150 produce => 'equation/', 151 display => 'WeBWorK::ContentGenerator::EquationDisplay', 152 }, 153 feedback => { 154 name => 'Feedback', 155 parent => 'set_list', 156 kids => [ qw// ], 157 match => qr|^feedback/|, 158 capture => [ qw// ], 159 produce => 'feedback/', 160 display => 'WeBWorK::ContentGenerator::Feedback', 161 }, 162 gateway_quiz => { 163 name => 'Gateway Quiz $setID', 164 parent => 'set_list', 165 kids => [ qw// ], 166 match => qr|^quiz_mode/([^/]+)/|, 167 capture => [ qw/setID/ ], 168 produce => 'quiz_mode/$setID/', 169 display => 'WeBWorK::ContentGenerator::GatewayQuiz', 170 }, 171 proctored_gateway_quiz => { 172 name => 'Proctored Gateway Quiz $setID', 173 parent => 'set_list', 174 kids => [ qw/proctored_gateway_proctor_login/ ], 175 match => qr|^proctored_quiz_mode/([^/]+)/|, 176 capture => [ qw/setID/ ], 177 produce => 'proctored_quiz_mode/$setID/', 178 display => 'WeBWorK::ContentGenerator::GatewayQuiz', 179 }, 180 proctored_gateway_proctor_login => { 181 name => 'Proctored Gateway Quiz $setID Proctor Login', 182 parent => 'proctored_gateway_quiz', 183 kids => [ qw// ], 184 match => qr|^proctored_quiz_mode/([^/]+)/|, 185 capture => [ qw/setID/ ], 186 produce => 'proctored_quiz_mode/$setID/proctor_login', 187 display => 'WeBWorK::ContentGenerator::LoginProctor', 188 }, 189 grades => { 190 name => 'Grades', 191 parent => 'set_list', 192 kids => [ qw// ], 193 match => qr|^grades/|, 194 capture => [ qw// ], 195 produce => 'grades/', 196 display => 'WeBWorK::ContentGenerator::Grades', 197 }, 198 hardcopy => { 199 name => 'Hardcopy Generator', 200 parent => 'set_list', 201 kids => [ qw/hardcopy_preselect_set/ ], 202 match => qr|^hardcopy/|, 203 capture => [ qw// ], 204 produce => 'hardcopy/', 205 display => 'WeBWorK::ContentGenerator::Hardcopy', 206 }, 207 hardcopy_preselect_set => { 208 name => 'Hardcopy Generator', 209 parent => 'hardcopy', 210 kids => [ qw// ], 211 match => qr|^([^/]+)/|, 212 capture => [ qw/setID/ ], 213 produce => '$setID/', 214 display => 'WeBWorK::ContentGenerator::Hardcopy', 215 }, 216 logout => { 217 name => 'Logout', 218 parent => 'set_list', 219 kids => [ qw// ], 220 match => qr|^logout/|, 221 capture => [ qw// ], 222 produce => 'logout/', 223 display => 'WeBWorK::ContentGenerator::Logout', 224 }, 225 options => { 226 name => 'Password/Email', 227 parent => 'set_list', 228 kids => [ qw// ], 229 match => qr|^options/|, 230 capture => [ qw// ], 231 produce => 'options/', 232 display => 'WeBWorK::ContentGenerator::Options', 233 }, 234 #test => { 235 # name => 'Test', 236 # parent => 'set_list', 237 # kids => [ qw// ], 238 # match => qr|^test/|, 239 # capture => [ qw// ], 240 # produce => 'test/', 241 # display => 'WeBWorK::ContentGenerator::Test', 242 #}, 243 244 ################################################################################ 245 246 instructor_tools => { 247 name => 'Instructor Tools', 248 parent => 'set_list', 249 kids => [ qw/instructor_user_list instructor_set_list instructor_add_users 250 instructor_set_assigner instructor_file_transfer instructor_file_manager 251 instructor_problem_editor instructor_set_maker instructor_compare 252 instructor_config 253 instructor_scoring instructor_scoring_download instructor_mail_merge 254 instructor_answer_log instructor_preflight instructor_statistics 255 instructor_progress 256 / ], 257 match => qr|^instructor/|, 258 capture => [ qw// ], 259 produce => 'instructor/', 260 display => 'WeBWorK::ContentGenerator::Instructor::Index', 261 }, 262 263 ################################################################################ 264 265 instructor_user_list => { 266 name => 'Classlist Editor', 267 parent => 'instructor_tools', 268 kids => [ qw/instructor_user_detail/ ], 269 match => qr|^users/|, 270 capture => [ qw// ], 271 produce => 'users/', 272 display => 'WeBWorK::ContentGenerator::Instructor::UserList', 273 }, 274 instructor_user_detail => { 275 name => 'Sets assigned to $userID', 276 parent => 'instructor_user_list', 277 kids => [ qw/instructor_sets_assigned_to_user/ ], 278 match => qr|^([^/]+)/|, 279 capture => [ qw/userID/ ], 280 produce => '$userID/', 281 display => 'WeBWorK::ContentGenerator::Instructor::UserDetail', 282 }, 283 instructor_sets_assigned_to_user => { 284 name => 'Sets Assigned to User', 285 parent => 'instructor_user_detail', 286 kids => [ qw// ], 287 match => qr|^sets/|, 288 capture => [ qw// ], 289 produce => 'sets/', 290 display => 'WeBWorK::ContentGenerator::Instructor::SetsAssignedToUser', 291 }, 292 293 ################################################################################ 294 295 instructor_set_list => { 296 name => 'Hmwk Sets Editor', 297 parent => 'instructor_tools', 298 kids => [ qw/instructor_set_detail/ ], 299 match => qr|^sets/|, 300 capture => [ qw// ], 301 produce => 'sets/', 302 display => 'WeBWorK::ContentGenerator::Instructor::ProblemSetList', 303 }, 304 instructor_set_detail => { 305 name => 'Set Detail for set $setID', 306 parent => 'instructor_set_list', 307 kids => [ qw/instructor_users_assigned_to_set/ ], 308 match => qr|^([^/]+)/|, 309 capture => [ qw/setID/ ], 310 produce => '$setID/', 311 display => 'WeBWorK::ContentGenerator::Instructor::ProblemSetDetail', 312 }, 313 instructor_users_assigned_to_set => { 314 name => 'Users Assigned to Set $setID', 315 parent => 'instructor_set_detail', 316 kids => [ qw// ], 317 match => qr|^users/|, 318 capture => [ qw// ], 319 produce => 'users/', 320 display => 'WeBWorK::ContentGenerator::Instructor::UsersAssignedToSet', 321 }, 322 323 ################################################################################ 324 325 instructor_add_users => { 326 name => 'Add Users', 327 parent => 'instructor_tools', 328 kids => [ qw// ], 329 match => qr|^add_users/|, 330 capture => [ qw// ], 331 produce => 'add_users/', 332 display => 'WeBWorK::ContentGenerator::Instructor::AddUsers', 333 }, 334 instructor_set_assigner => { 335 name => 'Set Assigner', 336 parent => 'instructor_tools', 337 kids => [ qw// ], 338 match => qr|^assigner/|, 339 capture => [ qw// ], 340 produce => 'assigner/', 341 display => 'WeBWorK::ContentGenerator::Instructor::Assigner', 342 }, 343 instructor_config => { 344 name => 'Course Configuration', 345 parent => 'instructor_tools', 346 kids => [ qw// ], 347 match => qr|^config/|, 348 capture => [ qw// ], 349 produce => 'config/', 350 display => 'WeBWorK::ContentGenerator::Instructor::Config', 351 }, 352 instructor_compare => { 353 name => 'File Compare', 354 parent => 'instructor_tools', 355 kids => [ qw// ], 356 match => qr|^compare/|, 357 capture => [ qw// ], 358 produce => 'comp/', 359 display => 'WeBWorK::ContentGenerator::Instructor::Compare', 360 }, 361 instructor_set_maker => { 362 name => 'Library Browser', 363 parent => 'instructor_tools', 364 kids => [ qw// ], 365 match => qr|^setmaker/|, 366 capture => [ qw// ], 367 produce => 'setmaker/', 368 display => 'WeBWorK::ContentGenerator::Instructor::SetMaker', 369 }, 370 instructor_file_transfer => { 371 name => 'File Transfer', 372 parent => 'instructor_tools', 373 kids => [ qw// ], 374 match => qr|^file_xfer/|, 375 capture => [ qw// ], 376 produce => 'file_xfer/', 377 display => 'WeBWorK::ContentGenerator::Instructor::FileXfer', 378 }, 379 instructor_file_manager => { 380 name => 'File Manager', 381 parent => 'instructor_tools', 382 kids => [ qw// ], 383 match => qr|^file_manager/|, 384 capture => [ qw// ], 385 produce => 'file_manager/', 386 display => 'WeBWorK::ContentGenerator::Instructor::FileManager', 387 }, 388 instructor_problem_editor => { 389 name => 'Problem Editor', 390 parent => 'instructor_tools', 391 kids => [ qw/instructor_problem_editor_withset/ ], 392 match => qr|^pgProblemEditor/|, 393 capture => [ qw// ], 394 produce => 'pgProblemEditor/', 395 display => 'WeBWorK::ContentGenerator::Instructor::PGProblemEditor', 396 }, 397 instructor_problem_editor_withset => { 398 name => '$setID', 399 parent => 'instructor_problem_editor', 400 kids => [ qw/instructor_problem_editor_withset_withproblem/ ], 401 match => qr|^([^/]+)/|, 402 capture => [ qw/setID/ ], 403 produce => '$setID/', 404 display => '', 405 }, 406 instructor_problem_editor_withset_withproblem => { 407 name => '$problemID', 408 parent => 'instructor_problem_editor_withset', 409 kids => [ qw// ], 410 match => qr|^([^/]+)/|, 411 capture => [ qw/problemID/ ], 412 produce => '$problemID/', 413 display => 'WeBWorK::ContentGenerator::Instructor::PGProblemEditor', 414 }, 415 instructor_scoring => { 416 name => 'Scoring Tools', 417 parent => 'instructor_tools', 418 kids => [ qw// ], 419 match => qr|^scoring/|, 420 capture => [ qw// ], 421 produce => 'scoring/', 422 display => 'WeBWorK::ContentGenerator::Instructor::Scoring', 423 }, 424 instructor_scoring_download => { 425 name => 'Scoring Download', 426 parent => 'instructor_tools', 427 kids => [ qw// ], 428 match => qr|^scoringDownload/|, 429 capture => [ qw// ], 430 produce => 'scoringDownload/', 431 display => 'WeBWorK::ContentGenerator::Instructor::ScoringDownload', 432 }, 433 instructor_mail_merge => { 434 name => 'Email', 435 parent => 'instructor_tools', 436 kids => [ qw// ], 437 match => qr|^send_mail/|, 438 capture => [ qw// ], 439 produce => 'send_mail/', 440 display => 'WeBWorK::ContentGenerator::Instructor::SendMail', 441 }, 442 instructor_answer_log => { 443 name => 'Answer Log', 444 parent => 'instructor_tools', 445 kids => [ qw// ], 446 match => qr|^show_answers/|, 447 capture => [ qw// ], 448 produce => 'show_answers/', 449 display => 'WeBWorK::ContentGenerator::Instructor::ShowAnswers', 450 }, 451 instructor_preflight => { 452 name => 'Preflight Log', 453 parent => 'instructor_tools', 454 kids => [ qw// ], 455 match => qr|^preflight/|, 456 capture => [ qw// ], 457 produce => 'preflight/', 458 display => 'WeBWorK::ContentGenerator::Instructor::Preflight', 459 }, 460 461 ################################################################################ 462 463 instructor_statistics => { 464 name => 'Statistics', 465 parent => 'instructor_tools', 466 kids => [ qw/instructor_set_statistics instructor_user_statistics/ ], 467 match => qr|^stats/|, 468 capture => [ qw// ], 469 produce => 'stats/', 470 display => 'WeBWorK::ContentGenerator::Instructor::Stats', 471 }, 472 instructor_set_statistics => { 473 name => 'Statistics', 474 parent => 'instructor_statistics', 475 kids => [ qw// ], 476 match => qr|^(set)/([^/]+)/|, 477 capture => [ qw/statType setID/ ], 478 produce => 'set/$setID/', 479 display => 'WeBWorK::ContentGenerator::Instructor::Stats', 480 }, 481 instructor_user_statistics => { 482 name => 'Statistics', 483 parent => 'instructor_statistics', 484 kids => [ qw// ], 485 match => qr|^(student)/([^/]+)/|, 486 capture => [ qw/statType userID/ ], 487 produce => 'student/$userID/', 488 display => 'WeBWorK::ContentGenerator::Instructor::Stats', 489 }, 490 491 ################################################################################ 492 493 instructor_progress => { 494 name => 'Student Progress', 495 parent => 'instructor_tools', 496 kids => [ qw/instructor_set_progress instructor_user_progress/ ], 497 match => qr|^progress/|, 498 capture => [ qw// ], 499 produce => 'progress/', 500 display => 'WeBWorK::ContentGenerator::Instructor::StudentProgress', 501 }, 502 instructor_set_progress => { 503 name => 'Student Progress', 504 parent => 'instructor_progress', 505 kids => [ qw// ], 506 match => qr|^(set)/([^/]+)/|, 507 capture => [ qw/statType setID/ ], 508 produce => 'set/$setID/', 509 display => 'WeBWorK::ContentGenerator::Instructor::StudentProgress', 510 }, 511 instructor_user_progress => { 512 name => 'Student Progress', 513 parent => 'instructor_progress', 514 kids => [ qw// ], 515 match => qr|^(student)/([^/]+)/|, 516 capture => [ qw/statType userID/ ], 517 produce => 'student/$userID/', 518 display => 'WeBWorK::ContentGenerator::Instructor::StudentProgress', 519 }, 520 521 ################################################################################ 522 523 problem_list => { 524 name => '$setID', 525 parent => 'set_list', 526 kids => [ qw/problem_detail/ ], 527 match => qr|^([^/]+)/|, 528 capture => [ qw/setID/ ], 529 produce => '$setID/', 530 display => 'WeBWorK::ContentGenerator::ProblemSet', 531 }, 532 problem_detail => { 533 name => '$problemID', 534 parent => 'problem_list', 535 kids => [ qw// ], 536 match => qr|^([^/]+)/|, 537 capture => [ qw/problemID/ ], 538 produce => '$problemID/', 539 display => 'WeBWorK::ContentGenerator::Problem', 540 }, 541 542 ); 543 544 =for comment 545 546 a handy template: 547 548 id => { 549 name => '', 550 parent => '', 551 kids => [ qw// ], 552 match => qr|^/|, 553 capture => [ qw// ], 554 produce => '', 555 display => '', 556 }, 557 558 =cut 559 560 ################################################################################ 561 562 =head1 CONSTRUCTORS 563 564 =over 565 566 =item new(%fields) 567 568 Creates a new WeBWorK::URLPath. %fields may contain the following: 569 570 type => the internal path type associated with this 571 args => a reference to a hash associating path arguments with values 572 573 This constructor is used internally. Refer to newFromPath() and newFromModule() 574 for more useful constructors. 575 576 =cut 577 578 sub new { 579 my ($invocant, %fields) = @_; 580 my $class = ref $invocant || $invocant; 581 my $self = { 582 type => undef, 583 args => {}, 584 %fields, 585 }; 586 return bless $self, $class; 587 } 588 589 =item newFromPath($path) 590 591 Creates a new WeBWorK::URLPath by parsing the path given in $path. It the path 592 is invalid, an exception is thrown. 593 594 =cut 595 596 sub newFromPath { 597 my ($invocant, $path) = @_; 598 599 my ($type, %args) = getPathType($path); 600 croak "no type matches path $path" unless $type; 601 602 return $invocant->new( 603 type => $type, 604 args => \%args, 605 ); 606 } 607 608 =item newFromModule($module, %args) 609 610 Creates a new WeBWorK::URLPath by finding a path type which matches the module 611 and path arguments given. If no type matches, an exception is thrown. 612 613 =cut 614 615 sub newFromModule { 616 my ($invocant, $module, %args) = @_; 617 618 my $type = getModuleType($module, keys %args); 619 croak "no type matches module $module with args", map { " $_=>$args{$_}" } keys %args unless $type; 620 621 return $invocant->new( 622 type => $type, 623 args => \%args 624 ); 625 } 626 627 =back 628 629 =cut 630 631 ################################################################################ 632 633 =head1 METHODS 634 635 =head2 Methods that return information from the object itself 636 637 =over 638 639 =item type() 640 641 Returns the path type of the WeBWorK::URLPath. 642 643 =cut 644 645 sub type { 646 my ($self) = @_; 647 my $type = $self->{type}; 648 649 return $type; 650 } 651 652 =item args() 653 654 Returns a hash of arguments derived from the WeBWorK::URLPath. 655 656 =cut 657 658 sub args { 659 my ($self) = @_; 660 my %args = %{ $self->{args} }; 661 662 return %args; 663 } 664 665 =item arg($name) 666 667 Returns the named argument, as derived from the WeBWorK::URLPath. 668 669 =cut 670 671 sub arg { 672 my ($self, $name) = @_; 673 my %args = %{ $self->{args} }; 674 675 return $args{$name}; 676 } 677 678 =back 679 680 =cut 681 682 # ------------------------------------------------------------------------------ 683 684 =head2 Methods that return information from path node associated with the object 685 686 =over 687 688 =item name() 689 690 Returns the human-readable name of this WeBWorK::URLPath. 691 692 =cut 693 694 sub name { 695 my ($self) = @_; 696 my $type = $self->{type}; 697 my %args = $self->args; 698 699 my $name = $pathTypes{$type}->{name}; 700 $name = interpolate($name, %args); 701 702 return $name; 703 } 704 705 =item module() 706 707 Returns the name of the module that will handle this WeBWorK::URLPath. 708 709 =cut 710 711 sub module { 712 my ($self) = @_; 713 my $type = $self->{type}; 714 715 return $pathTypes{$type}->{display}; 716 } 717 718 =back 719 720 =cut 721 722 # ------------------------------------------------------------------------------ 723 724 =head2 Methods that search the virtual heirarchy 725 726 =over 727 728 =item parent() 729 730 Returns a new WeBWorK::URLPath representing the parent of the current URLPath. 731 Returns an undefined value if the URLPath has no parent. 732 733 =cut 734 735 sub parent { 736 my ($self) = @_; 737 my $type = $self->{type}; 738 739 my $newType = $pathTypes{$self->{type}}->{parent}; 740 return undef unless $newType; 741 742 # remove any arguments added by the current node (and therefore not needed by the parent) 743 my @currArgs = @{ $pathTypes{$type}->{capture} }; 744 my %newArgs = %{ $self->{args} }; 745 delete @newArgs{@currArgs} if @currArgs; 746 747 return $self->new(type => $newType, args => \%newArgs); 748 } 749 750 =item child($module, %newArgs) 751 752 Returns a new WeBWorK::URLPath representing the child of the current URLPath 753 whose module is C<$module>. If no child matches, an undefined value is returned. 754 Pass additional arguments needed by the child in C<%newArgs>. 755 756 =cut 757 758 sub child { 759 my ($self, $module, %newArgs) = @_; 760 my $type = $self->{type}; 761 762 my @kids = @{ $pathTypes{$type}->{kids} }; 763 my $newType; 764 foreach my $kid (@kids) { 765 if ($pathTypes{$kid}->{module} eq $module) { 766 $newType = $kid; 767 last; 768 } 769 } 770 771 if ($newType) { 772 return $self->new(type => $newType, args => \%newArgs); 773 } else { 774 return undef; 775 } 776 } 777 778 =item path() 779 780 Reconstructs the path string from a WeBWorK::URLPath. 781 782 =cut 783 784 sub path { 785 my ($self) = @_; 786 my $type = $self->type; 787 my %args = %{ $self->{args} }; 788 789 my $path = buildPathFromType($type); 790 $path = interpolate($path, %args); 791 792 return $path; 793 } 794 795 =back 796 797 =cut 798 799 ################################################################################ 800 801 =head1 UTILITY FUNCTIONS 802 803 =over 804 805 =item interpolate($string, %symbols) 806 807 Replaces simple scalars (\$\w+) in $string with values in %symbols. If a scalar 808 does not exist in %symbols, it is left alone. 809 810 =cut 811 812 sub interpolate { 813 my ($string, %symbols) = @_; 814 815 $string =~ s/\$(\w+)/exists $symbols{$1} ? $symbols{$1} : "\$$1"/eg; 816 817 return $string; 818 } 819 820 =back 821 822 =cut 823 824 # ------------------------------------------------------------------------------ 825 826 =over 827 828 =item getPathType($path) 829 830 Parse the string $path, determining the path type. Returns ($type, %args), where 831 $type is the type of the path and %args contains any extracted path arguments. 832 If conversion fails, a false value is returned. 833 834 =cut 835 836 sub getPathType($) { 837 my ($path) = @_; 838 839 my %args; 840 my $context = visitPathTypeNode("root", $path, \%args, 0); 841 842 return $context, %args; 843 } 844 845 =item getModuleType($module, @args) 846 847 Returns the path type matching the given module and argument names, or a false 848 value if no type matches. 849 850 =cut 851 852 sub getModuleType { 853 my ($module, @args) = @_; 854 @args = sort @args; 855 my %args; 856 @args{@args} = (); 857 858 NODE: foreach my $nodeID (keys %pathTypes) { 859 my $node = $pathTypes{$nodeID}; 860 861 # module name matches? 862 next NODE unless defined $node->{display} and $node->{display} eq $module; 863 864 # collect all captures from here to root 865 my @captures; 866 my $tmpNodeID = $nodeID; 867 while ($tmpNodeID) { 868 my $tmpNode = $pathTypes{$tmpNodeID}; 869 push @captures, @{ $tmpNode->{capture} }; 870 $tmpNodeID = $tmpNode->{parent}; 871 } 872 873 # same number of captures? 874 next NODE unless @captures == @args; 875 876 # same captures? 877 @captures = sort @captures; 878 for (my $i = 0; $i < @args; $i++) { 879 next NODE unless $args[$i] eq $captures[$i]; 880 } 881 882 # if we got here, this node matches 883 return $nodeID; 884 } 885 886 return 0; # no node matches 887 } 888 889 =item buildPathFromType($type) 890 891 Returns a string path for the given path type. Since arguments are not supplied, 892 the string may contain scalar variables ripe for interpolation. 893 894 =cut 895 896 sub buildPathFromType($) { 897 my ($type) = @_; 898 899 my $path = ""; 900 901 while ($type) { 902 $path = $pathTypes{$type}->{produce} . $path; 903 $type = $pathTypes{$type}->{parent}; 904 }; 905 906 return $path; 907 } 908 909 =item visitPathTypeNode($nodeID, $path, $argsRef, $indent) 910 911 Internal search function. See getPathType(). 912 913 Returns the nodeID of the node that consumed the final characters in $path, or 914 the following failure conditions: 915 916 Returns 0 if $nodeID doesn't match $path. 917 918 Returns -1 if $nodeID matched $path, but no children of $nodeID consumed the 919 remaining path. In this case, the stack is unwound immediately. 920 921 =cut 922 923 sub visitPathTypeNode($$$$); 924 925 sub visitPathTypeNode($$$$) { 926 my ($nodeID, $path, $argsRef, $indent) = @_; 927 debug("visitPathTypeNode", $indent, "visiting node $nodeID with path $path"); 928 929 unless (exists $pathTypes{$nodeID}) { 930 debug("visitPathTypeNode", $indent, "node $nodeID doesn't exist in node list: failed"); 931 die "node $nodeID doesn't exist in node list: failed"; 932 } 933 934 my %node = %{ $pathTypes{$nodeID} }; 935 my $match = $node{match}; 936 my @capture_names = @{ $node{capture} }; 937 938 # attempt to match $path against $match. 939 debug("visitPathTypeNode", $indent, "trying to match $match: "); 940 if ($path =~ s/($match)//) { 941 # it matches! store captured strings in $argsRef and remove the matched 942 # characters from $path. waste a lot of lines on sanity checking... ;) 943 debug("", 0, "success!"); 944 my @capture_values = $1 =~ m/$match/; 945 if (@capture_names) { 946 my $nexpected = @capture_names; 947 my $ncaptured = @capture_values; 948 my $max = $nexpected > $ncaptured ? $nexpected : $ncaptured; 949 warn "captured $ncaptured arguments, expected $nexpected." unless $ncaptured == $nexpected; 950 for (my $i = 0; $i < $max; $i++) { 951 my $name = $capture_names[$i]; 952 my $value = $capture_values[$i]; 953 if ($i > $nexpected) { 954 warn "captured an unexpected argument: $value -- ignoring it."; 955 next; 956 } 957 if ($i > $ncaptured) { 958 warn "expected an uncaptured argument named: $name -- ignoring it."; 959 next; 960 } 961 if (exists $argsRef->{$name}) { 962 my $old = $argsRef->{$name}; 963 warn "encountered argument $name again, old value: $old new value: $value -- replacing."; 964 } 965 debug("visitPathTypeNode", $indent, "setting argument $name => $value."); 966 $argsRef->{$name} = $value; 967 } 968 } 969 } else { 970 # it doesn't match. bail out now with return value 0 971 debug("", 0, "failed."); 972 return 0; 973 } 974 975 ##### if we're here we matched ##### 976 977 # if there's no more path left, then this node is the one! return $nodeID 978 if ($path eq "") { 979 debug("visitPathTypeNode", $indent, "no path left, type is $nodeID"); 980 return $nodeID; 981 } 982 983 # otherwise, we have to send the remaining path to the node's children 984 debug("visitPathTypeNode", $indent, "but path remains: $path"); 985 my @kids = @{ $node{kids} }; 986 if (@kids) { 987 foreach my $kid (@kids) { 988 debug("visitPathTypeNode", $indent, "trying child $kid:"); 989 my $result = visitPathTypeNode($kid, $path, $argsRef, $indent+1); 990 # we return in two situations: 991 # if $result is -1, then the kid matched but couldn't consume the rest of the path 992 # if $result is the ID of a node, then the kid matched and consumed the rest of the path 993 # these are all true values (assuming that "0" isn't a valid node ID), so we say: 994 return $result if $result; 995 } 996 debug("visitPathTypeNode", $indent, "no children claimed the remaining path: failed."); 997 } else { 998 debug("visitPathTypeNode", $indent, "no children to claim the remaining path: failed."); 999 } 1000 1001 # in both of the above cases, we matched but couldn't provide children that 1002 # would consume the rest of the path. so we return -1, causing the whole 1003 # stack to unwind. WHEEEEEEE! 1004 return -1; 1005 } 1006 1007 =back 1008 1009 =cut 1010 1011 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |