1package Jifty::Dispatcher; 2use strict; 3use warnings; 4use Exporter; 5use Jifty::YAML; 6use base qw/Exporter Jifty::Object/; 7use Carp::Clan; # croak 8 9=head1 NAME 10 11Jifty::Dispatcher - The Jifty Dispatcher 12 13=head1 SYNOPSIS 14 15In B<MyApp::Dispatcher>: 16 17 package MyApp::Dispatcher; 18 use Jifty::Dispatcher -base; 19 20 under ['blog', 'wiki'] => [ 21 run { 22 default model => "MyApp::Model::\u$1" 23 }, 24 on PUT 'entries/*' => run { 25 set entry_id => $1; 26 show '/display/entry'; 27 }, 28 on '*/*' => run { 29 my ($page, $op) = ($1, $2); 30 my $item = get('model')->load($page) or next_rule; 31 32 set item => $item; 33 set page => $page; 34 set op => $op; 35 36 show "/display/$op"; 37 }, 38 on '*' => run { dispatch "$1/view" }, 39 on '' => show '/display/list', 40 ]; 41 under qr{logs/(\d+)} => [ 42 when { $1 > 100 } => show '/error', 43 set model => 'MyApp::Model::Log', 44 run { dispatch "/wiki/LogPage-$1" }, 45 ]; 46 # ... more rules ... 47 48=head1 DESCRIPTION 49 50C<Jifty::Dispatcher> takes requests for pages, walks through a 51dispatch table, possibly running code or transforming the request 52before finally handing off control to the templating system to display 53the page the user requested or whatever else the system has decided to 54display instead. 55 56Generally, this is B<not> the place to be performing model and user 57specific access control checks or updating your database based on what 58the user has sent in. You want to do that in your model 59classes. (Well, I<we> want you to do that, but you're free to ignore 60our advice). 61 62The Dispatcher runs rules in several stages: 63 64=over 65 66=item before 67 68B<before> rules are run before Jifty evaluates actions. They're the 69perfect place to enable or disable L<Jifty::Action>s using 70L<Jifty::API/allow> and L<Jifty::API/deny> or to completely disallow 71user access to private I<component> templates such as the F<_elements> 72directory in a default Jifty application. They're also the right way 73to enable L<Jifty::LetMe> actions. 74 75You can entirely stop processing with the C<redirect>, C<tangent> and 76C<abort> directives, though L</after> rules will still run. 77 78=item on 79 80L<on> rules are run after Jifty evaluates actions, so they have full 81access to the results actions users have performed. They're the right 82place to set up view-specific objects or load up values for your 83templates. 84 85Dispatcher directives are evaluated in order until we get to either a 86C<show>, C<redirect>, C<tangent> or C<abort>. 87 88=item after 89 90L<after> rules let you clean up after rendering your page. Delete your 91cache files, write your transaction logs, whatever. 92 93At this point, it's too late to C<show>, C<redirect>, C<tangent> or C<abort> 94page display. 95 96=back 97 98C<Jifty::Dispatcher> is intended to replace all the F<autohandler>, 99F<dhandler> and C<index.html> boilerplate code commonly found in Mason 100applications, but there's nothing stopping you from using those 101features in your application when they're more convenient. 102 103Each directive's code block runs in its own scope, but all share a 104common C<$Dispatcher> object. 105 106=cut 107 108=head1 Plugins and rule ordering 109 110By default, L<Jifty::Plugin> dispatcher rules are added in the order 111they are specified in the application's configuration file; that is, 112after all the plugin dispatchers have run in order, then the 113application's dispatcher runs. It is possible to specify rules which 114should be reordered with respect to this rule, however. This is done 115by using a variant on the C<before> and C<after> syntax: 116 117 before plugin NAME => 118 RULE(S); 119 120 after plugin NAME => 121 RULE(S); 122 123 after app, 124 RULE(S) 125 126C<NAME> may either be a string, which must match the plugin name 127exactly, or a regular expression, which is matched against the plugin 128name. The rule will be placed at the first boundary that it matches -- 129that is, given a C<before plugin qr/^Jifty::Plugin::Auth::/> and both 130a C<Jifty::Plugin::Auth::Basic> and a C<Jifty::Plugin::Auth::Complex>, 131the rules will be placed before the first. 132 133C<after app> inserts the following C<RULES> after the application's 134dispatcher rules, and is identical to, but hopefully clearer than, 135C<< after plugin Jifty => RULES >>. 136 137C<RULES> may either be a single C<before>, C<on>, C<under>, or 138C<after> rule to change the ordering of, or an array reference of 139rules to reorder. 140 141=cut 142 143=head1 Data your dispatch routines has access to 144 145=head2 request 146 147The current L<Jifty::Request> object. 148 149=head2 $Dispatcher 150 151The current dispatcher object. 152 153=head2 get $arg 154 155Return the argument value. 156 157=head1 Things your dispatch routine might do 158 159=head2 under $match => $rule 160 161Match against the current requested path. If matched, set the current 162context to the directory and process the rule. 163 164The C<$rule> may be an array reference of more rules, a code reference, a 165method name of your dispatcher class, or a fully qualified subroutine name. 166 167All wildcards in the C<$match> string becomes capturing regex patterns. You 168can also pass in an array reference of matches, or a regex pattern. 169 170The C<$match> string may be qualified with a HTTP method name or protocol, such as 171 172=over 173 174=item GET 175 176=item POST 177 178=item PUT 179 180=item OPTIONS 181 182=item DELETE 183 184=item HEAD 185 186=item HTTPS 187 188=item HTTP 189 190=back 191 192=head2 on $match => $rule 193 194Like C<under>, except it has to match the whole path instead of just the prefix. 195Does not set current directory context for its rules. 196 197=head2 before $match => $rule 198 199Just like C<on>, except it runs I<before> actions are evaluated. 200 201=head2 after $match => $rule 202 203Just like C<on>, except it runs I<after> the page is rendered. 204 205 206=head2 when {...} => $rule 207 208Like C<under>, except using an user-supplied test condition. You can stick 209any Perl you want inside the {...}; it's just an anonymous subroutine. 210 211=head2 run {...} 212 213Run a block of code unconditionally; all rules are allowed inside a C<run> 214block, as well as user code. You can think of the {...} as an anonymous 215subroutine. 216 217=head2 stream {...} 218 219Run a block of code unconditionally, which should return a coderef 220that is a PSGI streamy response. 221 222=head2 set $arg => $val 223 224Adds an argument to what we're passing to our template, overriding 225any value the user sent or we've already set. 226 227=head2 default $arg => $val 228 229Adds an argument to what we're passing to our template, 230but only if it is not defined currently. 231 232=head2 del $arg 233 234Deletes an argument we were passing to our template. 235 236=head2 show $component 237 238Display the presentation component. If not specified, use the 239request path as the default page. 240 241=head2 dispatch $path 242 243Dispatch again using $path as the request path, preserving args. 244 245=head2 next_rule 246 247Break out from the current C<run> block and go on the next rule. 248 249=head2 last_rule 250 251Break out from the current C<run> block and stop running rules in this stage. 252 253=head2 abort $code 254 255Abort the request; this skips straight to the cleanup stage. 256 257If C<$code> is specified, it's used as the HTTP status code. 258 259=head2 redirect $uri 260 261Redirect to another URI. 262 263=head2 tangent $uri 264 265Take a continuation here, and tangent to another URI. 266 267=head2 plugin 268 269=head2 app 270 271See L</Plugins and rule ordering>, above. 272 273=cut 274 275our @EXPORT = qw< 276 under run when set del default 277 278 before on after 279 280 show dispatch abort redirect tangent stream 281 282 GET POST PUT HEAD DELETE OPTIONS 283 284 HTTPS HTTP 285 286 plugin app 287 288 get next_rule last_rule 289 290 already_run 291 292 $Dispatcher 293>; 294 295our $Dispatcher; 296our $Request; 297 298sub request { $Request } 299sub _ret (@); 300sub under ($$@) { _ret @_ } # partial match at beginning of path component 301sub before ($$@) { _ret @_ } # exact match on the path component 302sub on ($$@) { _ret @_ } # exact match on the path component 303sub after ($$@) { _ret @_ } # exact match on the path component 304sub when (&@) { _ret @_ } # exact match on the path component 305sub run (&@) { _ret @_ } # execute a block of code 306sub stream (&@) { _ret @_ } # web return a PSGI-streamy response 307sub show (;$@) { _ret @_ } # render a page 308sub dispatch ($@) { _ret @_ } # run dispatch again with another URI 309sub redirect ($@) { _ret @_ } # web redirect 310sub tangent ($@) { _ret @_ } # web tangent 311sub abort (;$@) { _ret @_ } # abort request 312sub default ($$@) { _ret @_ } # set parameter if it's not yet set 313sub set ($$@) { _ret @_ } # set parameter 314sub del ($@) { _ret @_ } # remove parameter 315sub get ($) { 316 my $val = $Request->template_argument( $_[0] ); 317 return $val if defined $val; 318 return $Request->argument( $_[0] ); 319} 320 321sub _qualify ($@); 322sub GET ($) { _qualify method => @_ } 323sub POST ($) { _qualify method => @_ } 324sub PUT ($) { _qualify method => @_ } 325sub HEAD ($) { _qualify method => @_ } 326sub DELETE ($) { _qualify method => @_ } 327sub OPTIONS ($) { _qualify method => @_ } 328 329sub HTTPS ($) { _qualify https => @_ } 330sub HTTP ($) { _qualify http => @_ } 331 332sub plugin ($) { return { plugin => @_ } } 333sub app () { return { plugin => 'Jifty' } } 334 335our $CURRENT_STAGE; 336 337=head2 import 338 339Jifty::Dispatcher is an L<Exporter>, that is, part of its role is to 340blast a bunch of symbols into another package. In this case, that 341other package is the dispatcher for your application. 342 343You never call import directly. Just: 344 345 use Jifty::Dispatcher -base; 346 347in C<MyApp::Dispatcher> 348 349=cut 350 351sub import { 352 my $class = shift; 353 my $pkg = caller; 354 my @args = grep { !/^-[Bb]ase/ } @_; 355 356 no strict 'refs'; 357 no warnings 'once'; 358 for (qw(RULES_RUN RULES_SETUP RULES_CLEANUP RULES_DEFERRED)) { 359 @{ $pkg . '::' . $_ } = (); 360 } 361 if ( @args != @_ ) { 362 363 # User said "-base", let's push ourselves into their @ISA. 364 push @{ $pkg . '::ISA' }, $class; 365 366 # Turn on strict and warnings for them too, a la Moose 367 strict->import; 368 warnings->import; 369 } 370 371 $class->export_to_level( 1, @args ); 372} 373 374################################################### 375# Magically figure out the arity based on caller info. 376sub _ret (@) { 377 my $pkg = caller(1); 378 my $sub = ( caller(1) )[3]; 379 my $proto = prototype($sub); 380 my $op = $sub; 381 382 $proto =~ tr/@;//d; 383 if ( my $idx = rindex( $op, '::' ) ) { 384 $op = substr( $op, $idx + 2 ); 385 } 386 387 if ($Dispatcher) { 388 389 # We are under an operation -- carry the rule forward 390 foreach my $rule ( [ $op => splice( @_, 0, length($proto) ) ], @_ ) { 391 $Dispatcher->_handle_rule($rule); 392 } 393 } elsif (wantarray) { 394 ( [ $op => splice( @_, 0, length($proto) ) ], @_ ); 395 } elsif ( defined wantarray ) { 396 [ [ $op => splice( @_, 0, length($proto) ) ], @_ ]; 397 } else { 398 _push_rule($pkg, [ $op => splice( @_, 0, length($proto) ) ] ); 399 } 400} 401 402sub _push_rule($$) { 403 my($pkg, $rule) = @_; 404 my $op = $rule->[0]; 405 my $ruleset; 406 if ( ($op eq "before" or $op eq "after") and ref $rule->[1] and ref $rule->[1] eq 'HASH' and $rule->[1]{plugin} ) { 407 $ruleset = 'RULES_DEFERRED'; 408 } elsif ( $op eq 'before' ) { 409 $ruleset = 'RULES_SETUP'; 410 } elsif ( $op eq 'after' ) { 411 $ruleset = 'RULES_CLEANUP'; 412 } else { 413 $ruleset = 'RULES_RUN'; 414 } 415 no strict 'refs'; 416 # XXX TODO, need to spec stage here. 417 push @{ $pkg . '::' . $ruleset }, $rule; 418} 419 420sub _qualify ($@) { 421 my $key = shift; 422 my $op = ( caller(1) )[3]; 423 $op =~ s/.*:://; 424 return { $key => $op, '' => $_[0] }; 425} 426 427=head2 rules STAGE 428 429Returns an array of all the rules for the stage STAGE. 430 431Valid values for STAGE are 432 433=over 434 435=item SETUP 436 437=item RUN 438 439=item CLEANUP 440 441=back 442 443=cut 444 445sub rules { 446 my $self = shift; 447 my $stage = shift; 448 my $pkg = ref($self) || $self; 449 no strict 'refs'; 450 no warnings 'once'; 451 @{ $pkg . '::RULES_' . $stage }; 452} 453 454=head2 new 455 456Creates a new Jifty::Dispatcher object. You probably don't ever want 457to do this. (Jifty.pm does it for you) 458 459=cut 460 461sub new { 462 my $self = shift; 463 return $self if ref($self); 464 465 bless( 466 { cwd => '', 467 path => '', 468 rule => undef, 469 @_, 470 } => $self 471 ); 472} 473 474=head2 handle_request 475 476Actually do what your dispatcher does. For now, the right thing 477to do is to put the following two lines first: 478 479 require MyApp::Dispatcher; 480 MyApp::Dispatcher->handle_request; 481 482 483=cut 484 485sub handle_request { 486 my $self = shift; 487 488 local $Dispatcher = $self->new(); 489 490 # XXX TODO: refactor this out somehow? 491 # We don't want the previous mason request hanging aroudn once we start dispatching 492 no warnings 'once'; 493 local $HTML::Mason::Commands::m = undef; 494 # Mason introduces a DIE handler that generates a mason exception 495 # which in turn generates a backtrace. That's fine when you only 496 # do it once per request. But it's really, really painful when you 497 # do it often, as is the case with fragments 498 local $SIG{__DIE__} = 'DEFAULT'; 499 local $Request = Jifty->web->request; 500 501 my $handler = $Dispatcher->can("fragment_handler"); 502 if ($Request->is_subrequest and $handler) { 503 $handler->(); 504 return undef; 505 } 506 eval { 507 $Dispatcher->_do_dispatch( Jifty->web->request->path); 508 }; 509 if ( my $err = $@ ) { 510 $self->log->warn(ref($err) . " " ."'$err'") if ( $err !~ /^ABORT/ ); 511 } 512 return $Dispatcher->{stream}; 513} 514 515=head2 _handle_stage NAME, EXTRA_RULES 516 517Handles the all rules in the stage named C<NAME>. Additionally, any 518other arguments passed after the stage C<NAME> are added to the end of 519the rules for that stage. 520 521This is the unit which calling L</last_rule> skips to the end of. 522 523=cut 524 525sub _handle_stage { 526 my ($self, $stage, @rules) = @_; 527 528 # Set the current stage so that rules can make smarter choices; 529 local $CURRENT_STAGE = $stage; 530 Jifty->handler->call_trigger("before_dispatcher_$stage"); 531 532 eval { $self->_handle_rules( [ $self->rules($stage), @rules ] ); }; 533 if ( my $err = $@ ) { 534 $self->log->warn( ref($err) . " " . "'$err'" ) 535 if ( $err !~ /^(LAST RULE|ABORT)/ ); 536 Jifty->handler->call_trigger("after_dispatcher_$stage"); 537 return $err =~ /^ABORT/ ? 0 : 1; 538 } 539 Jifty->handler->call_trigger("after_dispatcher_$stage"); 540 return 1; 541} 542 543=head2 _handle_rules RULESET 544 545When handed an arrayref or array of rules (RULESET), walks through the 546rules in order, executing as it goes. 547 548 549=cut 550 551sub _handle_rules ($) { 552 my ( $self, $rules ) = @_; 553 554 my @rules; 555 { 556 local $@; 557 eval { @rules = @$rules }; 558 @rules = $rules if $@; 559 } 560RULE: foreach my $rule (@rules) { 561 $self->_handle_rule($rule); 562 } 563} 564 565=head2 _handle_rule RULE 566 567When handed a single rule in the form of a coderef, C<_handle_rule>, 568calls C<_do_run> on that rule and returns the result. When handed a 569rule that turns out to be an array of subrules, recursively calls 570itself and evaluates the subrules in order. 571 572=cut 573 574sub _handle_rule { 575 my ( $self, $rule ) = @_; 576 my ( $op, @args ); 577 578 # Handle the case where $rule is an array reference. 579 if (ref($rule) eq 'ARRAY') { 580 ( $op, @args ) = @$rule; 581 } else { 582 ( $op, @args ) = ( run => $rule ); 583 } 584 585 # Handle the case where $op is an array. 586 my $sub_rules; 587 if (ref($op) eq 'ARRAY' ) { 588 $sub_rules = [ @$op, @args ]; 589 } 590 591 if ($sub_rules) { 592 for my $sub_rule (@$sub_rules) { 593 $self->_handle_rule($sub_rule); 594 } 595 } 596 597 # Now we know op is a scalar. 598 local $self->{rule} = $op; 599 my $meth = "_do_$op"; 600 $self->$meth(@args); 601 602} 603 604no warnings 'exiting'; 605 606sub next_rule { next RULE } 607sub last_rule { die "LAST RULE" } 608 609=head2 _do_under 610 611This method is called by the dispatcher internally. You shouldn't need to. 612 613=cut 614 615sub _do_under { 616 my ( $self, $cond, $rules ) = @_; 617 if ( my $regex = $self->_match($cond) ) { 618 619 $self->log->debug("Matched 'under' rule $cond as $regex for ".$self->{'path'}); 620 # match again to establish $1 $2 etc in the dynamic scope 621 $self->{path} =~ $regex; 622 623 # enter the matched directory 624 local $self->{cwd} = substr( $self->{path}, 0, $+[0] ); 625 chop $self->{cwd} if substr( $self->{cwd}, -1 ) eq '/'; 626 627 $self->_handle_rules($rules); 628 } 629} 630 631=head2 _do_when 632 633This method is called by the dispatcher internally. You shouldn't need to. 634 635=cut 636 637sub _do_when { 638 my ( $self, $code, $rules ) = @_; 639 if ( $code->() ) { 640 $self->_handle_rules($rules); 641 } 642} 643 644=head2 _do_before 645 646This method is called by the dispatcher internally. You shouldn't need to. 647 648=cut 649 650sub _do_before { 651 my ( $self, $cond, $rules ) = @_; 652 if ( my $regex = $self->_match($cond) ) { 653 654 $self->log->debug("Matched 'before' rule $cond as $regex for ".$self->{'path'}); 655 # match again to establish $1 $2 etc in the dynamic scope 656 $self->{path} =~ $regex; 657 $self->_handle_rules($rules); 658 } 659 660} 661 662=head2 _do_on 663 664This method is called by the dispatcher internally. You shouldn't need to. 665 666=cut 667 668sub _do_on { 669 my ( $self, $cond, $rules ) = @_; 670 if ( my $regex = $self->_match($cond) ) { 671 672 $self->log->debug("Matched 'on' rule $cond as $regex for ".$self->{'path'}); 673 # match again to establish $1 $2 etc in the dynamic scope 674 $self->{path} =~ $regex; 675 $self->_handle_rules($rules); 676 } 677} 678 679=head2 _do_after 680 681This method is called by the dispatcher internally. You shouldn't need to. 682 683=cut 684 685sub _do_after { 686 my ( $self, $cond, $rules ) = @_; 687 if ( my $regex = $self->_match($cond) ) { 688 $self->log->debug("Matched 'after' rule $cond as $regex for ".$self->{'path'}); 689 # match again to establish $1 $2 etc in the dynamic scope 690 $self->{path} =~ $regex; 691 $self->_handle_rules($rules); 692 } 693} 694 695=head2 already_run 696 697Returns true if the code block has run once already in this request. 698This can be useful for 'after' rules to ensure that they only run 699once, even if there is a sub-dispatch which would cause it to run more 700than once. The idiom is: 701 702 after '/some/path/*' => run { 703 return if already_run; 704 # ... 705 }; 706 707=cut 708 709sub already_run { 710 my $id = $Dispatcher->{call_rule}; 711 return 1 if get "__seen_$id"; 712 set "__seen_$id" => 1; 713 return 0; 714} 715 716sub _do_run { 717 my ( $self, $code ) = @_; 718 719 # Keep track of the coderef being run, so we can know about 720 # already_run 721 local $self->{call_rule} = $code; 722 723 # establish void context and make a call 724 ( $self->can($code) || $code )->(); 725 726 # XXX maybe call with all the $1..$x as @_ too? or is it too gonzo? 727 # $code->(map { substr($PATH, $-[$_], ($+[$_]-$-[$_])) } 1..$#-)); 728 729 return; 730} 731 732=head2 _do_redirect PATH 733 734This method is called by the dispatcher internally. You shouldn't need to. 735 736Redirect the user to the URL provided in the mandatory PATH argument. 737 738=cut 739 740sub _do_redirect { 741 my ( $self, $path ) = @_; 742 $self->log->debug("Redirecting to $path"); 743 Jifty->web->redirect($path); 744} 745 746=head2 _do_tangent PATH 747 748This method is called by the dispatcher internally. You shouldn't need to. 749 750Take a tangent to the URL provided in the mandatory PATH argument. 751(See L<Jifty::Manual::Continuation> for more about tangents.) 752 753=cut 754 755sub _do_tangent { 756 my ( $self, $path ) = @_; 757 $self->log->debug("Taking a tangent to $path"); 758 Jifty->web->tangent(url => $path); 759} 760 761=head2 _do_stream CODE 762 763The method is called by the dispatcher internally. You shouldn't need to. 764 765Take a coderef that returns a PSGI streamy response code. 766 767=cut 768 769sub _do_stream { 770 my ( $self, $code ) = @_; 771 $self->{stream} = $code->(); 772 $self->_abort; 773} 774 775=head2 _do_abort 776 777This method is called by the dispatcher internally. You shouldn't need to. 778 779Don't display any page. just stop. 780 781=cut 782 783sub _do_abort { 784 my $self = shift; 785 $self->log->debug("Aborting processing"); 786 if (my $code = shift) { 787 # This is the status code 788 Jifty->web->response->status( $code ); 789 if ( $code == 403 && !Jifty->web->response->body) { 790 Jifty->web->response->content_type('text/plain'); 791 Jifty->web->response->body('403 Forbidden'); 792 } 793 } 794 $self->_abort; 795} 796 797sub _abort { die "ABORT" } 798 799=head2 _do_show [PATH] 800 801This method is called by the dispatcher internally. You shouldn't need to. 802 803Render a template. If the scalar argument "PATH" is given, render that component. 804Otherwise, just render whatever we were going to anyway. 805 806=cut 807 808 809sub _do_show { 810 my $self = shift; 811 my $path; 812 813 # Fix up the path 814 $path = shift if (@_); 815 $path = $self->{path} unless defined $path and length $path; 816 817 unless ($CURRENT_STAGE eq 'RUN') { 818 croak "You can't call a 'show' rule in a 'before' or 'after' block in the dispatcher. Not showing path $path"; 819 } 820 821 # If we've got a working directory (from an "under" rule) and we have 822 # a relative path, prepend the working directory 823 $path = "$self->{cwd}/$path" unless $path =~ m{^/}; 824 825 Jifty->web->render_template( $path ); 826 827 last_rule; 828} 829 830sub _do_set { 831 my ( $self, $key, $value ) = @_; 832 no warnings 'uninitialized'; 833 $self->log->debug("Setting argument $key to $value"); 834 $Request->template_argument($key, $value); 835} 836 837sub _do_del { 838 my ( $self, $key ) = @_; 839 $self->log->debug("Deleting argument $key"); 840 $Request->delete($key); 841} 842 843sub _do_default { 844 my ( $self, $key, $value ) = @_; 845 no warnings 'uninitialized'; 846 $self->log->debug("Setting argument default $key to $value"); 847 $Request->template_argument($key, $value) 848 unless defined $Request->argument($key) or defined $Request->template_argument($key); 849} 850 851=head2 _do_dispatch [PATH] 852 853First, this routine runs all the C<before> dispatcher rules, then it runs 854Jifty->web->handle_request(), then it runs all the main C<on> rules, 855evaluating each one in turn. If it gets through all the rules without 856running an C<abort>, C<redirect> or C<show> directive, it C<shows> 857the template originally requested. 858 859Once it's done with that, it runs all the cleanup rules defined with C<after>. 860 861=cut 862 863sub _do_dispatch { 864 my $self = shift; 865 866 # Requests should always start with a leading / 867 $self->{path} = "/".shift; 868 $self->{cwd} = ''; 869 870 # Normalize the path. 871 $self->{path} =~ s{/+}{/}g; 872 873 $self->log->debug("Dispatching request to ".$self->{path}); 874 875 # Disable most actions on GET requests 876 Jifty->api->deny_for_get() if $self->_match_method('GET') 877 and not Jifty->web->request->is_subrequest; 878 879 # Setup -- we we don't abort out of setup, then run the 880 # actions and then the RUN stage. 881 if ($self->_handle_stage('SETUP')) { 882 # Run actions 883 Jifty->web->handle_request unless Jifty->web->request->is_subrequest; 884 885 # Run, and show the page 886 $self->_handle_stage('RUN' => 'show'); 887 } 888 889 # Close the handle down, so the client can go on their merry way 890 unless (Jifty->web->request->is_subrequest) { 891 Jifty->handler->call_trigger("before_flush"); 892 Jifty->handler->buffer->flush_output; 893 # XXX: flush 894 #close(STDOUT); 895 #$Jifty::SERVER->close_client_sockets if $Jifty::SERVER; 896 Jifty->handler->call_trigger("after_flush"); 897 } 898 899 # Cleanup 900 $self->_handle_stage('CLEANUP'); 901 902 # Out to the next dispatcher's cleanup; since try/catch using die 903 # is slow, we only do this if we're not in the topmost dispatcher. 904 $self->_abort if $self->{path} ne "/"; 905} 906 907=head2 _match CONDITION 908 909Returns the regular expression matched if the current request fits 910the condition defined by CONDITION. 911 912C<CONDITION> can be a regular expression, a "simple string" with shell 913wildcard characters (C<*>, C<?>, C<#>, C<[]>, C<{}>) to match against, 914or an arrayref or hashref of those. It should even be nestable. 915 916Arrayref conditions represents alternatives: the match succeeds as soon 917as the first match is found. 918 919Hashref conditions are conjunctions: each non-empty hash key triggers a 920separate C<_match_$keyname> call on the dispatcher object. For example, a 921C<method> key would call C<_match_method> with its value to be matched against. 922After each subcondition is tried (in lexicographical order) and succeeded, 923the value associated with the C<''> key is matched again as the condition. 924 925=cut 926 927sub _match { 928 my ( $self, $cond ) = @_; 929 930 # Handle the case where $cond is an array. 931 if ( ref($cond) eq 'ARRAY' ) { 932 local $@; 933 my $rv = eval { 934 for my $sub_cond (@$cond) 935 { 936 return ( $self->_match($sub_cond) or next ); 937 } 938 }; 939 if ( my $err = $@ ) { 940 warn "$self _match failed: $err"; 941 } else { 942 return $rv; 943 } 944 } 945 946 # Handle the case where $cond is a hash. 947 elsif ( ref($cond) eq 'HASH' ) { 948 local $@; 949 my $rv = eval { 950 for my $key ( sort grep {length} keys %$cond ) 951 { 952 my $meth = "_match_$key"; 953 $self->$meth( $cond->{$key} ) or return; 954 } 955 956 # All precondition passed, get original condition literal 957 return $self->_match( $cond->{''} ) if $cond->{''}; 958 959 # Or, if we don't have a literal, we win. 960 return 1; 961 }; 962 if ( my $err = $@ ) { 963 warn "$self _match failed: $err"; 964 } else { 965 return $rv; 966 } 967 } 968 969 # Now we know $cond is a scalar, match against it. 970 else { 971 my $regex = $self->_compile_condition($cond) or return; 972 $self->{path} =~ $regex or return; 973 return $regex; 974 } 975} 976 977=head2 _match_method METHOD 978 979Takes an HTTP method. Returns true if the current request 980came in with that method. 981 982=cut 983 984sub _match_method { 985 my ( $self, $method ) = @_; 986 #$self->log->debug("Matching method ".Jifty->web->request->method." against ".$method); 987 $Request->method eq uc($method); 988} 989 990=head2 _match_https 991 992Returns true if the current request is under SSL. 993 994=cut 995 996sub _match_https { 997 my $self = shift; 998 $self->log->debug("Matching request against HTTPS"); 999 return Jifty->web->request->secure; 1000} 1001 1002=head2 _match_http 1003 1004Returns true if the current request is not under SSL. 1005 1006=cut 1007 1008sub _match_http { 1009 my $self = shift; 1010 $self->log->debug("Matching request against HTTP"); 1011 return !Jifty->web->request->secure; 1012} 1013 1014sub _match_plugin { 1015 my ( $self, $plugin ) = @_; 1016 warn "Deferred check shouldn't happen"; 1017 return 0; 1018} 1019 1020=head2 _compile_condition CONDITION 1021 1022Takes a condition defined as a simple string and return it as a regex 1023condition. 1024 1025=cut 1026 1027 1028my %CONDITION_CACHE; 1029 1030sub _compile_condition { 1031 my ( $self, $cond ) = @_; 1032 1033 # Previously compiled (eg. a qr{} -- return it verbatim) 1034 return $cond if ref $cond; 1035 1036 my $cachekey = join('-', 1037 (($Dispatcher->{rule} eq 'on') ? 'on' : 'in'), 1038 $self->{cwd}, 1039 $cond); 1040 unless ( $CONDITION_CACHE{$cachekey} ) { 1041 1042 my $compiled = $cond; 1043 1044 # Escape and normalize 1045 $compiled = quotemeta($compiled); 1046 $compiled =~ s{(?:\\\/)+}{/}g; 1047 $compiled =~ s{/$}{}; 1048 1049 my $has_capture = ( $compiled =~ / \\ [*?#] /x ); 1050 if ( $has_capture or $compiled =~ / \\ [[{] /x ) { 1051 $compiled = $self->_compile_glob($compiled); 1052 } 1053 1054 if ( $compiled =~ m{^/} ) { 1055 1056 # '/foo' => qr{^/foo} 1057 $compiled = "\\A$compiled"; 1058 } elsif ( length($compiled) ) { 1059 1060 # 'foo' => qr{^$cwd/foo} 1061 $compiled = "(?<=\\A\Q$self->{cwd}\E/)$compiled"; 1062 } else { 1063 1064 # empty path -- just match $cwd itself 1065 $compiled = "(?<=\\A\Q$self->{cwd}\E)"; 1066 } 1067 1068 if ( $Dispatcher->{rule} eq 'on' ) { 1069 1070 # "on" anchors on complete match only 1071 $compiled .= '/?\\z'; 1072 } else { 1073 1074 # "in" anchors on prefix match in directory boundary 1075 $compiled .= '(?=/|\\z)'; 1076 } 1077 1078 # Make all metachars into capturing submatches 1079 if ( !$has_capture ) { 1080 $compiled = "($compiled)"; 1081 } 1082 $CONDITION_CACHE{$cachekey} = qr{$compiled}; 1083 } 1084 return $CONDITION_CACHE{$cachekey}; 1085} 1086 1087=head2 _compile_glob METAEXPRESSION 1088 1089Private function. 1090 1091Turns a metaexpression containing C<*>, C<?> and C<#> into a capturing regex pattern. 1092 1093Also supports the non-capturing C<[]> and C<{}> notations. 1094 1095The rules are: 1096 1097=over 4 1098 1099=item * 1100 1101A C<*> between two C</> characters, or between a C</> and end of string, 1102should match one or more non-slash characters: 1103 1104 /foo/*/bar 1105 /foo/*/ 1106 /foo/* 1107 /* 1108 1109=item * 1110 1111All other C<*> can match zero or more non-slash characters: 1112 1113 /*bar 1114 /foo*bar 1115 * 1116 1117=item * 1118 1119Two stars (C<**>) can match zero or more characters, including slash: 1120 1121 /**/bar 1122 /foo/** 1123 ** 1124 1125=item * 1126 1127Consecutive C<?> marks are captured together: 1128 1129 /foo???bar # One capture for ??? 1130 /foo??* # Two captures, one for ?? and one for * 1131 1132=item * 1133 1134The C<#> character captures one or more digit characters. 1135 1136=item * 1137 1138Brackets such as C<[a-z]> denote character classes; they are not captured. 1139 1140=item * 1141 1142Braces such as C<{xxx,yyy}]> denote alternations; they are not captured. 1143 1144=back 1145 1146=cut 1147 1148sub _compile_glob { 1149 my ( $self, $glob ) = @_; 1150 $glob =~ s{ 1151 # Stars between two slashes, or between a slash and end-of-string, 1152 # should at match one or more non-slash characters. 1153 (?<= /) # lookbehind for slash 1154 \\ \* # star 1155 (?= / | \z) # lookahead for slash or end-of-string 1156 }{([^/]+)}gx; 1157 $glob =~ s{ 1158 # Two stars can match zero or more characters, including slash. 1159 \\ \* \\ \* 1160 }{(.*)}gx; 1161 $glob =~ s{ 1162 # All other stars can match zero or more non-slash character. 1163 \\ \* 1164 }{([^/]*)}gx; 1165 $glob =~ s{ 1166 # The number-sign character matches one or more digits. 1167 \\ \# 1168 }{(\\d+)}gx; 1169 $glob =~ s{ 1170 # Consecutive question marks are captured as one unit; 1171 # we do this by capturing them and then repeat the result pattern 1172 # for that many times. The divide-by-two takes care of the 1173 # extra backslashes. 1174 ( (?: \\ \? )+ ) 1175 }{([^/]{${ \( length($1)/2 ) }})}gx; 1176 $glob =~ s{ 1177 # Brackets denote character classes 1178 ( 1179 \\ \[ # opening 1180 (?: # one or more characters: 1181 \\ \\ \\ \] # ...escaped closing bracket 1182 | 1183 \\ [^\]] # ...escaped (but not the closing bracket) 1184 | 1185 [^\\] # ...normal 1186 )+ 1187 \\ \] # closing 1188 ) 1189 }{$self->_unescape($1)}egx; 1190 $glob =~ s{ 1191 # Braces denote alternations 1192 \\ \{ ( # opening (not part of expression) 1193 (?: # zero or more characters: 1194 \\ \\ \\ \} # ...escaped closing brace 1195 | 1196 \\ [^\}] # ...escaped (but not the closing brace) 1197 | 1198 [^\\] # ...normal 1199 )+ 1200 ) \\ \} # closing (not part of expression) 1201 }{'(?:'.join('|', split(/\\,/, $1, -1)).')'}egx; 1202 $glob; 1203} 1204 1205sub _unescape { 1206 my $self = shift; 1207 my $text = shift; 1208 $text =~ s{\\(.)}{$1}g; 1209 return $text; 1210} 1211 1212 1213 1214=head2 import_plugins 1215 1216Imports rules from L<Jifty/plugins> into the main dispatcher's space. 1217 1218=cut 1219 1220sub import_plugins { 1221 my $self = shift; 1222 1223 # Find the deferred rules 1224 my @deferred; 1225 push @deferred, $_->dispatcher->rules('DEFERRED') for Jifty->plugins; 1226 push @deferred, $self->rules('DEFERRED'); 1227 1228 # XXX TODO: Examine @deferred and find rules that cannot fire 1229 # because they match no plugins; they should become un-deferred in 1230 # the appropriate group. This is so 'before plugin qr/Auth/' runs 1231 # even if we have no auth plugin 1232 1233 for my $stage (qw/SETUP RUN CLEANUP/) { 1234 my @groups; 1235 push @groups, {name => ref $_, rules => [$_->dispatcher->rules($stage)]} for Jifty->plugins; 1236 push @groups, {name => 'Jifty', rules => [$self->rules($stage)]}; 1237 1238 my @left; 1239 my @rules; 1240 for (@groups) { 1241 my $name = $_->{name}; 1242 my @group_rules = @{$_->{rules}}; 1243 1244 # XXX TODO: 'after' rules should possibly be placed after 1245 # the *last* thing they could match 1246 push @rules, $self->_match_deferred(\@deferred, before => $name, $stage); 1247 push @rules, @group_rules; 1248 push @rules, $self->_match_deferred(\@deferred, after => $name, $stage); 1249 } 1250 1251 no strict 'refs'; 1252 @{ $self . "::RULES_$stage" } = @rules; 1253 } 1254 if (@deferred) { 1255 warn "Leftover unmatched deferred rules: ".Jifty::YAML::Dump(\@deferred); 1256 } 1257} 1258 1259sub _match_deferred { 1260 my $self = shift; 1261 my ($deferred, $time, $name, $stage) = @_; 1262 my %stages = (SETUP => "before", RUN => "on", CLEANUP => "after"); 1263 $stage = $stages{$stage}; 1264 1265 my @matches; 1266 for my $op (@{$deferred}) { 1267 # Only care if we're on the correct side of the correct plugin 1268 next unless $op->[0] eq $time; 1269 1270 # Regex or string match, appropriately 1271 next unless ( 1272 ref $op->[1]{plugin} 1273 ? ( $name =~ $op->[1]{plugin} ) 1274 : ( $op->[1]{plugin} eq $name ) ); 1275 1276 # Find the list of subrules 1277 my @subrules = ref $op->[2] eq "ARRAY" ? @{$op->[2]} : ($op->[2]); 1278 1279 # Only toplevel rules make sense (before, after, on) 1280 warn "Invalid subrule ".$_->[0] for grep {$_->[0] !~ /^(before|on|after)$/} @subrules; 1281 @subrules = grep {$_->[0] =~ /^(before|on|after)$/} @subrules; 1282 1283 # Only match if the stage matches 1284 push @matches, grep {$_->[0] eq $stage} @subrules; 1285 @subrules = grep {$_->[0] ne $stage} @subrules; 1286 1287 $op->[2] = [@subrules]; 1288 } 1289 1290 # Clean out any completely matched rules 1291 @$deferred = grep {@{$_->[2]}} @$deferred; 1292 1293 return @matches; 1294} 1295 12961; 1297