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