lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5 use UNIVERSAL::require;
   6 use Data::Dumper;
   7 use HTML::Entities;
   8 use HTTP::Headers;
   9 use Memoize;
  10 use Time::HiRes qw/gettimeofday tv_interval/;
  11 use Tree::Simple;
  12 use Tree::Simple::Visitor::FindByPath;
  13 use Catalyst::Request;
  14 use Catalyst::Response;
  15
  16 require Module::Pluggable::Fast;
  17
  18 $Data::Dumper::Terse = 1;
  19
  20 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
  21 __PACKAGE__->mk_accessors(qw/request response state/);
  22
  23 __PACKAGE__->actions(
  24     { plain => {}, private => {}, regex => {}, compiled => {}, reverse => {} }
  25 );
  26 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
  27
  28 *comp = \&component;
  29 *req  = \&request;
  30 *res  = \&response;
  31
  32 our $COUNT = 1;
  33 our $START = time;
  34
  35 memoize('_class2prefix');
  36
  37 =head1 NAME
  38
  39 Catalyst::Engine - The Catalyst Engine
  40
  41 =head1 SYNOPSIS
  42
  43 See L<Catalyst>.
  44
  45 =head1 DESCRIPTION
  46
  47 =head1 METHODS
  48
  49 =over 4
  50
  51 =item $c->action( $name => $coderef, ... )
  52
  53 Add one or more actions.
  54
  55     $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
  56
  57 It also automatically calls setup() if needed.
  58
  59 See L<Catalyst::Manual::Intro> for more informations about actions.
  60
  61 =cut
  62
  63 sub action {
  64     my $self = shift;
  65     $self->setup unless $self->components;
  66     $self->actions( {} ) unless $self->actions;
  67     my $action;
  68     $_[1] ? ( $action = {@_} ) : ( $action = shift );
  69     if ( ref $action eq 'HASH' ) {
  70         while ( my ( $name, $code ) = each %$action ) {
  71             $self->set_action( $name, $code, caller(0) );
  72         }
  73     }
  74     return 1;
  75 }
  76
  77 =item $c->benchmark($coderef)
  78
  79 Takes a coderef with arguments and returns elapsed time as float.
  80
  81     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
  82     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
  83
  84 =cut
  85
  86 sub benchmark {
  87     my $c       = shift;
  88     my $code    = shift;
  89     my $time    = [gettimeofday];
  90     my @return  = &$code(@_);
  91     my $elapsed = tv_interval $time;
  92     return wantarray ? ( $elapsed, @return ) : $elapsed;
  93 }
  94
  95 =item $c->comp($name)
  96
  97 =item $c->component($name)
  98
  99 Get a component object by name.
 100
 101     $c->comp('MyApp::Model::MyModel')->do_stuff;
 102
 103 Regex search for a component.
 104
 105     $c->comp('mymodel')->do_stuff;
 106
 107 =cut
 108
 109 sub component {
 110     my ( $c, $name ) = @_;
 111     if ( my $component = $c->components->{$name} ) {
 112         return $component;
 113     }
 114     else {
 115         for my $component ( keys %{ $c->components } ) {
 116             return $c->components->{$component} if $component =~ /$name/i;
 117         }
 118     }
 119 }
 120
 121 =item $c->errors
 122
 123 =item $c->errors($error, ...)
 124
 125 =item $c->errors($arrayref)
 126
 127 Returns an arrayref containing errors messages.
 128
 129     my @errors = @{ $c->errors };
 130
 131 Add a new error.
 132
 133     $c->errors('Something bad happened');
 134
 135 =cut
 136
 137 sub errors {
 138     my $c = shift;
 139     my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 140     push @{ $c->{errors} }, @$errors;
 141     return $c->{errors};
 142 }
 143
 144 =item $c->finalize
 145
 146 Finalize request.
 147
 148 =cut
 149
 150 sub finalize {
 151     my $c = shift;
 152
 153     if ( my $location = $c->res->redirect ) {
 154         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 155         $c->res->headers->header( Location => $location );
 156         $c->res->status(302);
 157     }
 158
 159     if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
 160         $c->res->headers->content_type('text/html');
 161         my $name = $c->config->{name} || 'Catalyst Application';
 162         my ( $title, $errors, $infos );
 163         if ( $c->debug ) {
 164             $errors = join '<br/>', @{ $c->errors };
 165             $errors ||= 'No output';
 166             $title = $name = "$name on Catalyst $Catalyst::VERSION";
 167             my $req   = encode_entities Dumper $c->req;
 168             my $res   = encode_entities Dumper $c->res;
 169             my $stash = encode_entities Dumper $c->stash;
 170             $infos = <<"";
 171 <br/>
 172 <b><u>Request</u></b><br/>
 173 <pre>$req</pre>
 174 <b><u>Response</u></b><br/>
 175 <pre>$res</pre>
 176 <b><u>Stash</u></b><br/>
 177 <pre>$stash</pre>
 178
 179         }
 180         else {
 181             $title  = $name;
 182             $errors = '';
 183             $infos  = <<"";
 184 <pre>
 185 (en) Please come back later
 186 (de) Bitte versuchen sie es spaeter nocheinmal
 187 (nl) Gelieve te komen later terug
 188 (no) Vennligst prov igjen senere
 189 (fr) Veuillez revenir plus tard
 190 (es) Vuelto por favor mas adelante
 191 (pt) Voltado por favor mais tarde
 192 (it) Ritornato prego più successivamente
 193 </pre>
 194
 195             $name = '';
 196         }
 197         $c->res->{output} = <<"";
 198 <html>
 199     <head>
 200         <title>$title</title>
 201         <style type="text/css">
 202             body {
 203                 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 204                              Tahoma, Arial, helvetica, sans-serif;
 205                 color: #ddd;
 206                 background-color: #eee;
 207                 margin: 0px;
 208                 padding: 0px;
 209             }
 210             div.box {
 211                 background-color: #ccc;
 212                 border: 1px solid #aaa;
 213                 padding: 4px;
 214                 margin: 10px;
 215                 -moz-border-radius: 10px;
 216             }
 217             div.errors {
 218                 background-color: #977;
 219                 border: 1px solid #755;
 220                 padding: 8px;
 221                 margin: 4px;
 222                 margin-bottom: 10px;
 223                 -moz-border-radius: 10px;
 224             }
 225             div.infos {
 226                 background-color: #797;
 227                 border: 1px solid #575;
 228                 padding: 8px;
 229                 margin: 4px;
 230                 margin-bottom: 10px;
 231                 -moz-border-radius: 10px;
 232             }
 233             div.name {
 234                 background-color: #779;
 235                 border: 1px solid #557;
 236                 padding: 8px;
 237                 margin: 4px;
 238                 -moz-border-radius: 10px;
 239             }
 240         </style>
 241     </head>
 242     <body>
 243         <div class="box">
 244             <div class="errors">$errors</div>
 245             <div class="infos">$infos</div>
 246             <div class="name">$name</div>
 247         </div>
 248     </body>
 249 </html>
 250
 251     }
 252     $c->res->headers->content_length( length $c->res->output );
 253     my $status = $c->finalize_headers;
 254     $c->finalize_output;
 255     return $status;
 256 }
 257
 258 =item $c->finalize_headers
 259
 260 Finalize headers.
 261
 262 =cut
 263
 264 sub finalize_headers { }
 265
 266 =item $c->finalize_output
 267
 268 Finalize output.
 269
 270 =cut
 271
 272 sub finalize_output { }
 273
 274 =item $c->forward($command)
 275
 276 Forward processing to a private/public action or a method from a class.
 277 If you define a class without method it will default to process().
 278
 279     $c->forward('!foo');
 280     $c->forward('index.html');
 281     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 282     $c->forward('MyApp::View::TT');
 283
 284 =cut
 285
 286 sub forward {
 287     my $c       = shift;
 288     my $command = shift;
 289     $c->state(0);
 290     unless ($command) {
 291         $c->log->debug('Nothing to forward to') if $c->debug;
 292         return 0;
 293     }
 294     my $caller = caller(0);
 295     if ( $command =~ /^\?(.*)$/ ) {
 296         $command = $1;
 297         $command = _prefix( $caller, $command );
 298     }
 299     my $namespace = '';
 300     if ( $command =~ /^\!/ ) {
 301         $namespace = _class2prefix($caller);
 302     }
 303     my $results = $c->get_action( $command, $namespace );
 304     if ( @{$results} ) {
 305         unless ( $command =~ /^\!/ ) {
 306             $results = [ pop @{$results} ];
 307             if ( $results->[0]->[2] ) {
 308                 $c->log->debug(qq/Couldn't forward "$command" to regex action/)
 309                   if $c->debug;
 310                 return 0;
 311             }
 312         }
 313     }
 314     else {
 315         my $class = $command;
 316         if ( $class =~ /[^\w\:]/ ) {
 317             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 318             return 0;
 319         }
 320         my $method = shift || 'process';
 321         if ( my $code = $class->can($method) ) {
 322             $c->actions->{reverse}->{"$code"} = "$class->$method";
 323             $results = [ [ [ $class, $code ] ] ];
 324         }
 325         else {
 326             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 327               if $c->debug;
 328             return 0;
 329         }
 330     }
 331     for my $result ( @{$results} ) {
 332         my ( $class, $code ) = @{ $result->[0] };
 333         $class = $c->comp->{$class} || $class;
 334         $c->state( $c->process( $class, $code ) );
 335     }
 336     return $c->state;
 337 }
 338
 339 =item $c->get_action( $action, $namespace )
 340
 341 Get an action in a given namespace.
 342
 343 =cut
 344
 345 sub get_action {
 346     my ( $c, $action, $namespace ) = @_;
 347     $namespace ||= '';
 348     if ( $action =~ /^\!(.*)/ ) {
 349         $action = $1;
 350         my $parent = $c->tree;
 351         my @results;
 352         my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
 353         push @results, [$result] if $result;
 354         my $visitor = Tree::Simple::Visitor::FindByPath->new;
 355         my $local;
 356         for my $part ( split '/', $namespace ) {
 357             $local = undef;
 358             $visitor->setSearchPath($part);
 359             $parent->accept($visitor);
 360             my $child = $visitor->getResult;
 361             my $uid   = $child->getUID if $child;
 362             my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
 363             return [ [$match] ] if ( $match && $match =~ /^?.*/ );
 364             $local = $c->actions->{private}->{$uid}->{"?$action"} if $uid;
 365             push @results, [$match] if $match;
 366             $parent = $child if $child;
 367         }
 368         return [ [$local] ] if $local;
 369         return \@results;
 370     }
 371     elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
 372     elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
 373     else {
 374         for my $regex ( keys %{ $c->actions->{compiled} } ) {
 375             my $name = $c->actions->{compiled}->{$regex};
 376             if ( $action =~ $regex ) {
 377                 my @snippets;
 378                 for my $i ( 1 .. 9 ) {
 379                     no strict 'refs';
 380                     last unless ${$i};
 381                     push @snippets, ${$i};
 382                 }
 383                 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
 384             }
 385         }
 386     }
 387     return [];
 388 }
 389
 390 =item $c->handler( $class, $r )
 391
 392 Handles the request.
 393
 394 =cut
 395
 396 sub handler ($$) {
 397     my ( $class, $r ) = @_;
 398
 399     # Always expect worst case!
 400     my $status = -1;
 401     eval {
 402         my $handler = sub {
 403             my $c         = $class->prepare($r);
 404             my $action    = $c->req->action;
 405             my $namespace = '';
 406             $namespace = join '/', @{ $c->req->args } if $action eq '!default';
 407             unless ($namespace) {
 408                 if ( my $result = $c->get_action($action) ) {
 409                     $namespace = _class2prefix( $result->[0]->[0]->[0] );
 410                 }
 411             }
 412             my $results = $c->get_action( $action, $namespace );
 413             if ( @{$results} ) {
 414                 for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
 415                     $c->state( $c->process( @{ $begin->[0] } ) );
 416                 }
 417                 for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
 418                     $c->state( $c->process( @{ $result->[0] } ) );
 419                 }
 420                 for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
 421                     $c->state( $c->process( @{ $end->[0] } ) );
 422                 }
 423             }
 424             else {
 425                 my $path  = $c->req->path;
 426                 my $error = $path
 427                   ? qq/Unknown resource "$path"/
 428                   : "No default action defined";
 429                 $c->log->error($error) if $c->debug;
 430                 $c->errors($error);
 431             }
 432             return $c->finalize;
 433         };
 434         if ( $class->debug ) {
 435             my $elapsed;
 436             ( $elapsed, $status ) = $class->benchmark($handler);
 437             $elapsed = sprintf '%f', $elapsed;
 438             my $av = sprintf '%.3f', 1 / $elapsed;
 439             $class->log->info( "Request took $elapsed" . "s ($av/s)" );
 440         }
 441         else { $status = &$handler }
 442     };
 443     if ( my $error = $@ ) {
 444         chomp $error;
 445         $class->log->error(qq/Caught exception in engine "$error"/);
 446     }
 447     $COUNT++;
 448     return $status;
 449 }
 450
 451 =item $c->prepare($r)
 452
 453 Turns the engine-specific request (Apache, CGI...) into a Catalyst context.
 454
 455 =cut
 456
 457 sub prepare {
 458     my ( $class, $r ) = @_;
 459     my $c = bless {
 460         request => Catalyst::Request->new(
 461             {
 462                 arguments  => [],
 463                 cookies    => {},
 464                 headers    => HTTP::Headers->new,
 465                 parameters => {},
 466                 snippets   => [],
 467                 uploads    => {}
 468             }
 469         ),
 470         response => Catalyst::Response->new(
 471             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 472         ),
 473         stash => {},
 474         state => 0
 475     }, $class;
 476     if ( $c->debug ) {
 477         my $secs = time - $START || 1;
 478         my $av = sprintf '%.3f', $COUNT / $secs;
 479         $c->log->debug('********************************');
 480         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 481         $c->log->debug('********************************');
 482         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 483     }
 484     $c->prepare_request($r);
 485     $c->prepare_path;
 486     $c->prepare_cookies;
 487     $c->prepare_headers;
 488     $c->prepare_connection;
 489     my $method   = $c->req->method   || '';
 490     my $path     = $c->req->path     || '';
 491     my $hostname = $c->req->hostname || '';
 492     my $address  = $c->req->address  || '';
 493     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 494       if $c->debug;
 495     $c->prepare_action;
 496     $c->prepare_parameters;
 497
 498     if ( $c->debug && keys %{ $c->req->params } ) {
 499         my @params;
 500         for my $key ( keys %{ $c->req->params } ) {
 501             my $value = $c->req->params->{$key} || '';
 502             push @params, "$key=$value";
 503         }
 504         $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
 505     }
 506     $c->prepare_uploads;
 507     return $c;
 508 }
 509
 510 =item $c->prepare_action
 511
 512 Prepare action.
 513
 514 =cut
 515
 516 sub prepare_action {
 517     my $c    = shift;
 518     my $path = $c->req->path;
 519     my @path = split /\//, $c->req->path;
 520     $c->req->args( \my @args );
 521     while (@path) {
 522         $path = join '/', @path;
 523         if ( my $result = ${ $c->get_action($path) }[0] ) {
 524
 525             # It's a regex
 526             if ($#$result) {
 527                 my $match    = $result->[1];
 528                 my @snippets = @{ $result->[2] };
 529                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 530                   if $c->debug;
 531                 $c->log->debug(
 532                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 533                   if ( $c->debug && @snippets );
 534                 $c->req->action($match);
 535                 $c->req->snippets( \@snippets );
 536             }
 537             else {
 538                 $c->req->action($path);
 539                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 540             }
 541             $c->req->match($path);
 542             last;
 543         }
 544         unshift @args, pop @path;
 545     }
 546     unless ( $c->req->action ) {
 547         $c->req->action('!default');
 548         $c->req->match('');
 549     }
 550     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 551       if ( $c->debug && @args );
 552 }
 553
 554 =item $c->prepare_connection
 555
 556 Prepare connection.
 557
 558 =cut
 559
 560 sub prepare_connection { }
 561
 562 =item $c->prepare_cookies
 563
 564 Prepare cookies.
 565
 566 =cut
 567
 568 sub prepare_cookies { }
 569
 570 =item $c->prepare_headers
 571
 572 Prepare headers.
 573
 574 =cut
 575
 576 sub prepare_headers { }
 577
 578 =item $c->prepare_parameters
 579
 580 Prepare parameters.
 581
 582 =cut
 583
 584 sub prepare_parameters { }
 585
 586 =item $c->prepare_path
 587
 588 Prepare path and base.
 589
 590 =cut
 591
 592 sub prepare_path { }
 593
 594 =item $c->prepare_request
 595
 596 Prepare the engine request.
 597
 598 =cut
 599
 600 sub prepare_request { }
 601
 602 =item $c->prepare_uploads
 603
 604 Prepare uploads.
 605
 606 =cut
 607
 608 sub prepare_uploads { }
 609
 610 =item $c->process($class, $coderef)
 611
 612 Process a coderef in given class and catch exceptions.
 613 Errors are available via $c->errors.
 614
 615 =cut
 616
 617 sub process {
 618     my ( $c, $class, $code ) = @_;
 619     my $status;
 620     eval {
 621         if ( $c->debug )
 622         {
 623             my $action = $c->actions->{reverse}->{"$code"} || "$code";
 624             my $elapsed;
 625             ( $elapsed, $status ) =
 626               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 627             $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
 628               if $c->debug;
 629         }
 630         else { $status = &$code( $class, $c, @{ $c->req->args } ) }
 631     };
 632     if ( my $error = $@ ) {
 633         chomp $error;
 634         $error = qq/Caught exception "$error"/;
 635         $c->log->error($error);
 636         $c->errors($error) if $c->debug;
 637         return 0;
 638     }
 639     return $status;
 640 }
 641
 642 =item $c->run
 643
 644 Starts the engine.
 645
 646 =cut
 647
 648 sub run { }
 649
 650 =item $c->request
 651
 652 =item $c->req
 653
 654 Returns a C<Catalyst::Request> object.
 655
 656     my $req = $c->req;
 657
 658 =item $c->response
 659
 660 =item $c->res
 661
 662 Returns a C<Catalyst::Response> object.
 663
 664     my $res = $c->res;
 665
 666 =item $c->set_action( $action, $code, $namespace )
 667
 668 Set an action in a given namespace.
 669
 670 =cut
 671
 672 sub set_action {
 673     my ( $c, $action, $code, $namespace ) = @_;
 674     my $prefix = '';
 675     if ( $action =~ /^\?(.*)$/ ) {
 676         my $prefix = $1 || '';
 677         $action = $2;
 678         $action = $prefix . _prefix( $namespace, $action );
 679         $c->actions->{plain}->{$action} = [ $namespace, $code ];
 680     }
 681     elsif ( $action =~ /^\/(.*)\/$/ ) {
 682         my $regex = $1;
 683         $c->actions->{compiled}->{qr#$regex#} = $action;
 684         $c->actions->{regex}->{$action} = [ $namespace, $code ];
 685     }
 686     elsif ( $action =~ /^\!(.*)$/ ) {
 687         $action = $1;
 688         my $parent  = $c->tree;
 689         my $visitor = Tree::Simple::Visitor::FindByPath->new;
 690         $prefix = _class2prefix($namespace);
 691         for my $part ( split '/', $prefix ) {
 692             $visitor->setSearchPath($part);
 693             $parent->accept($visitor);
 694             my $child = $visitor->getResult;
 695             unless ($child) {
 696                 $child = $parent->addChild( Tree::Simple->new($part) );
 697                 $visitor->setSearchPath($part);
 698                 $parent->accept($visitor);
 699                 $child = $visitor->getResult;
 700             }
 701             $parent = $child;
 702         }
 703         my $uid = $parent->getUID;
 704         $c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
 705         $action = "!$action";
 706     }
 707     else { $c->actions->{plain}->{$action} = [ $namespace, $code ] }
 708     my $reverse = $prefix ? "$action ($prefix)" : $action;
 709     $c->actions->{reverse}->{"$code"} = $reverse;
 710     $c->log->debug(qq/"$namespace" defined "$action" as "$code"/) if $c->debug;
 711 }
 712
 713 =item $class->setup
 714
 715 Setup.
 716
 717     MyApp->setup;
 718
 719 =cut
 720
 721 sub setup {
 722     my $self = shift;
 723     $self->setup_components;
 724     if ( $self->debug ) {
 725         my $name = $self->config->{name} || 'Application';
 726         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 727     }
 728 }
 729
 730 =item $class->setup_components
 731
 732 Setup components.
 733
 734 =cut
 735
 736 sub setup_components {
 737     my $self = shift;
 738
 739     # Components
 740     my $class = ref $self || $self;
 741     eval <<"";
 742         package $class;
 743         import Module::Pluggable::Fast
 744           name   => '_components',
 745           search => [
 746             '$class\::Controller', '$class\::C',
 747             '$class\::Model',      '$class\::M',
 748             '$class\::View',       '$class\::V'
 749           ];
 750
 751     if ( my $error = $@ ) {
 752         chomp $error;
 753         $self->log->error(
 754             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 755     }
 756     $self->components( {} );
 757     for my $component ( $self->_components($self) ) {
 758         $self->components->{ ref $component } = $component;
 759     }
 760     $self->log->debug( 'Initialized components "'
 761           . join( ' ', keys %{ $self->components } )
 762           . '"' )
 763       if $self->debug;
 764 }
 765
 766 =item $c->stash
 767
 768 Returns a hashref containing all your data.
 769
 770     $c->stash->{foo} ||= 'yada';
 771     print $c->stash->{foo};
 772
 773 =cut
 774
 775 sub stash {
 776     my $self = shift;
 777     if ( $_[0] ) {
 778         my $stash = $_[1] ? {@_} : $_[0];
 779         while ( my ( $key, $val ) = each %$stash ) {
 780             $self->{stash}->{$key} = $val;
 781         }
 782     }
 783     return $self->{stash};
 784 }
 785
 786 sub _prefix {
 787     my ( $class, $name ) = @_;
 788     my $prefix = _class2prefix($class);
 789     warn "$class - $name - $prefix";
 790     $name = "$prefix/$name" if $prefix;
 791     return $name;
 792 }
 793
 794 sub _class2prefix {
 795     my $class = shift || '';
 796     $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
 797     my $prefix = lc $2 || '';
 798     $prefix =~ s/\:\:/\//g;
 799     return $prefix;
 800 }
 801
 802 =back
 803
 804 =head1 AUTHOR
 805
 806 Sebastian Riedel, C<sri@cpan.org>
 807
 808 =head1 COPYRIGHT
 809
 810 This program is free software, you can redistribute it and/or modify it under
 811 the same terms as Perl itself.
 812
 813 =cut
 814
 815 1;