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