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     unless ($command) {
 290         $c->log->debug('Nothing to forward to') if $c->debug;
 291         return 0;
 292     }
 293     my $caller = caller(0);
 294     if ( $command =~ /^\?(.*)$/ ) {
 295         $command = $1;
 296         $command = _prefix( $caller, $command );
 297     }
 298     my $namespace = '';
 299     if ( $command =~ /^\!/ ) {
 300         $namespace = _class2prefix($caller);
 301     }
 302     my $results = $c->get_action( $command, $namespace );
 303     if ( @{$results} ) {
 304         if ( $command =~ /^\!/ ) {
 305             for my $result ( @{$results} ) {
 306                 my ( $class, $code ) = @{ $result->[0] };
 307                 $c->state( $c->process( $class, $code ) );
 308             }
 309         }
 310         else {
 311             return 0 unless my $result = $results->[0];
 312             if ( $result->[2] ) {
 313                 $c->log->debug(qq/Couldn't forward "$command" to regex action/)
 314                   if $c->debug;
 315                 return 0;
 316             }
 317             my ( $class, $code ) = @{ $result->[0] };
 318             $class = $c->components->{$class} || $class;
 319             $c->state( $c->process( $class, $code ) );
 320         }
 321     }
 322     else {
 323         my $class = $command;
 324         if ( $class =~ /[^\w\:]/ ) {
 325             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 326             return 0;
 327         }
 328         my $method = shift || 'process';
 329         if ( my $code = $class->can($method) ) {
 330             $c->actions->{reverse}->{"$code"} = "$class->$method";
 331             $class = $c->comp($class) || $class;
 332             $c->state( $c->process( $class, $code ) );
 333         }
 334         else {
 335             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 336               if $c->debug;
 337             return 0;
 338         }
 339     }
 340     return $c->state;
 341 }
 342
 343 =item $c->get_action( $action, $namespace )
 344
 345 Get an action in a given namespace.
 346
 347 =cut
 348
 349 sub get_action {
 350     my ( $c, $action, $namespace ) = @_;
 351     $namespace ||= '';
 352     if ( $action =~ /^\!(.*)/ ) {
 353         $action = $1;
 354         my $parent = $c->tree;
 355         my @results;
 356         my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
 357         push @results, [$result] if $result;
 358         my $visitor = Tree::Simple::Visitor::FindByPath->new;
 359         my $local;
 360         for my $part ( split '/', $namespace ) {
 361             $local = undef;
 362             $visitor->setSearchPath($part);
 363             $parent->accept($visitor);
 364             my $child = $visitor->getResult;
 365             my $uid   = $child->getUID if $child;
 366             my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
 367             $local = $c->actions->{private}->{$uid}->{"?$action"} if $uid;
 368             push @results, [$match] if $match;
 369             $parent = $child if $child;
 370         }
 371         return [ [$local] ] if $local;
 372         return \@results;
 373     }
 374     elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
 375     elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
 376     else {
 377         for my $regex ( keys %{ $c->actions->{compiled} } ) {
 378             my $name = $c->actions->{compiled}->{$regex};
 379             if ( $action =~ $regex ) {
 380                 my @snippets;
 381                 for my $i ( 1 .. 9 ) {
 382                     no strict 'refs';
 383                     last unless ${$i};
 384                     push @snippets, ${$i};
 385                 }
 386                 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
 387             }
 388         }
 389     }
 390     return [];
 391 }
 392
 393 =item $c->handler( $class, $r )
 394
 395 Handles the request.
 396
 397 =cut
 398
 399 sub handler ($$) {
 400     my ( $class, $r ) = @_;
 401
 402     # Always expect worst case!
 403     my $status = -1;
 404     eval {
 405         my $handler = sub {
 406             my $c         = $class->prepare($r);
 407             my $action    = $c->req->action;
 408             my $namespace = '';
 409             $namespace = join '/', @{ $c->req->args } if $action eq '!default';
 410             unless ($namespace) {
 411                 if ( my $result = $c->get_action($action) ) {
 412                     $namespace = _class2prefix( $result->[0]->[0]->[0] );
 413                 }
 414             }
 415             my $results = $c->get_action( $action, $namespace );
 416             if ( @{$results} ) {
 417                 for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
 418                     $c->state( $c->process( @{ $begin->[0] } ) );
 419                 }
 420                 for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
 421                     $c->state( $c->process( @{ $result->[0] } ) );
 422                 }
 423                 for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
 424                     $c->state( $c->process( @{ $end->[0] } ) );
 425                 }
 426             }
 427             else {
 428                 my $path  = $c->req->path;
 429                 my $error = $path
 430                   ? qq/Unknown resource "$path"/
 431                   : "No default action defined";
 432                 $c->log->error($error) if $c->debug;
 433                 $c->errors($error);
 434             }
 435             return $c->finalize;
 436         };
 437         if ( $class->debug ) {
 438             my $elapsed;
 439             ( $elapsed, $status ) = $class->benchmark($handler);
 440             $elapsed = sprintf '%f', $elapsed;
 441             my $av = sprintf '%.3f', 1 / $elapsed;
 442             $class->log->info( "Request took $elapsed" . "s ($av/s)" );
 443         }
 444         else { $status = &$handler }
 445     };
 446     if ( my $error = $@ ) {
 447         chomp $error;
 448         $class->log->error(qq/Caught exception in engine "$error"/);
 449     }
 450     $COUNT++;
 451     return $status;
 452 }
 453
 454 =item $c->prepare($r)
 455
 456 Turns the engine-specific request (Apache, CGI...) into a Catalyst context.
 457
 458 =cut
 459
 460 sub prepare {
 461     my ( $class, $r ) = @_;
 462     my $c = bless {
 463         request => Catalyst::Request->new(
 464             {
 465                 arguments  => [],
 466                 cookies    => {},
 467                 headers    => HTTP::Headers->new,
 468                 parameters => {},
 469                 snippets   => [],
 470                 uploads    => {}
 471             }
 472         ),
 473         response => Catalyst::Response->new(
 474             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 475         ),
 476         stash => {},
 477         state => 0
 478     }, $class;
 479     if ( $c->debug ) {
 480         my $secs = time - $START || 1;
 481         my $av = sprintf '%.3f', $COUNT / $secs;
 482         $c->log->debug('********************************');
 483         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 484         $c->log->debug('********************************');
 485         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 486     }
 487     $c->prepare_request($r);
 488     $c->prepare_path;
 489     $c->prepare_cookies;
 490     $c->prepare_headers;
 491     $c->prepare_connection;
 492     my $method   = $c->req->method   || '';
 493     my $path     = $c->req->path     || '';
 494     my $hostname = $c->req->hostname || '';
 495     my $address  = $c->req->address  || '';
 496     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 497       if $c->debug;
 498     $c->prepare_action;
 499     $c->prepare_parameters;
 500
 501     if ( $c->debug && keys %{ $c->req->params } ) {
 502         my @params;
 503         for my $key ( keys %{ $c->req->params } ) {
 504             my $value = $c->req->params->{$key} || '';
 505             push @params, "$key=$value";
 506         }
 507         $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
 508     }
 509     $c->prepare_uploads;
 510     return $c;
 511 }
 512
 513 =item $c->prepare_action
 514
 515 Prepare action.
 516
 517 =cut
 518
 519 sub prepare_action {
 520     my $c    = shift;
 521     my $path = $c->req->path;
 522     my @path = split /\//, $c->req->path;
 523     $c->req->args( \my @args );
 524     while (@path) {
 525         $path = join '/', @path;
 526         if ( my $result = ${ $c->get_action($path) }[0] ) {
 527
 528             # It's a regex
 529             if ($#$result) {
 530                 my $match    = $result->[1];
 531                 my @snippets = @{ $result->[2] };
 532                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 533                   if $c->debug;
 534                 $c->log->debug(
 535                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 536                   if ( $c->debug && @snippets );
 537                 $c->req->action($match);
 538                 $c->req->snippets( \@snippets );
 539             }
 540             else {
 541                 $c->req->action($path);
 542                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 543             }
 544             $c->req->match($path);
 545             last;
 546         }
 547         unshift @args, pop @path;
 548     }
 549     unless ( $c->req->action ) {
 550         $c->req->action('!default');
 551         $c->req->match('');
 552     }
 553     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 554       if ( $c->debug && @args );
 555 }
 556
 557 =item $c->prepare_connection
 558
 559 Prepare connection.
 560
 561 =cut
 562
 563 sub prepare_connection { }
 564
 565 =item $c->prepare_cookies
 566
 567 Prepare cookies.
 568
 569 =cut
 570
 571 sub prepare_cookies { }
 572
 573 =item $c->prepare_headers
 574
 575 Prepare headers.
 576
 577 =cut
 578
 579 sub prepare_headers { }
 580
 581 =item $c->prepare_parameters
 582
 583 Prepare parameters.
 584
 585 =cut
 586
 587 sub prepare_parameters { }
 588
 589 =item $c->prepare_path
 590
 591 Prepare path and base.
 592
 593 =cut
 594
 595 sub prepare_path { }
 596
 597 =item $c->prepare_request
 598
 599 Prepare the engine request.
 600
 601 =cut
 602
 603 sub prepare_request { }
 604
 605 =item $c->prepare_uploads
 606
 607 Prepare uploads.
 608
 609 =cut
 610
 611 sub prepare_uploads { }
 612
 613 =item $c->process($class, $coderef)
 614
 615 Process a coderef in given class and catch exceptions.
 616 Errors are available via $c->errors.
 617
 618 =cut
 619
 620 sub process {
 621     my ( $c, $class, $code ) = @_;
 622     my $status;
 623     eval {
 624         if ( $c->debug )
 625         {
 626             my $action = $c->actions->{reverse}->{"$code"} || "$code";
 627             my $elapsed;
 628             ( $elapsed, $status ) =
 629               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 630             $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
 631               if $c->debug;
 632         }
 633         else { $status = &$code( $class, $c, @{ $c->req->args } ) }
 634     };
 635     if ( my $error = $@ ) {
 636         chomp $error;
 637         $error = qq/Caught exception "$error"/;
 638         $c->log->error($error);
 639         $c->errors($error) if $c->debug;
 640         return 0;
 641     }
 642     return $status;
 643 }
 644
 645 =item $c->run
 646
 647 Starts the engine.
 648
 649 =cut
 650
 651 sub run { }
 652
 653 =item $c->request
 654
 655 =item $c->req
 656
 657 Returns a C<Catalyst::Request> object.
 658
 659     my $req = $c->req;
 660
 661 =item $c->response
 662
 663 =item $c->res
 664
 665 Returns a C<Catalyst::Response> object.
 666
 667     my $res = $c->res;
 668
 669 =item $c->set_action( $action, $code, $namespace )
 670
 671 Set an action in a given namespace.
 672
 673 =cut
 674
 675 sub set_action {
 676     my ( $c, $action, $code, $namespace ) = @_;
 677     my $prefix = '';
 678     if ( $action =~ /^\?(.*)$/ ) {
 679         my $prefix = $1 || '';
 680         $action = $2;
 681         $action = $prefix . _prefix( $namespace, $action );
 682         $c->actions->{plain}->{$action} = [ $namespace, $code ];
 683     }
 684     elsif ( $action =~ /^\/(.*)\/$/ ) {
 685         my $regex = $1;
 686         $c->actions->{compiled}->{qr#$regex#} = $action;
 687         $c->actions->{regex}->{$action} = [ $namespace, $code ];
 688     }
 689     elsif ( $action =~ /^\!(.*)$/ ) {
 690         $action = $1;
 691         my $parent  = $c->tree;
 692         my $visitor = Tree::Simple::Visitor::FindByPath->new;
 693         $prefix = _class2prefix($namespace);
 694         for my $part ( split '/', $prefix ) {
 695             $visitor->setSearchPath($part);
 696             $parent->accept($visitor);
 697             my $child = $visitor->getResult;
 698             unless ($child) {
 699                 $child = $parent->addChild( Tree::Simple->new($part) );
 700                 $visitor->setSearchPath($part);
 701                 $parent->accept($visitor);
 702                 $child = $visitor->getResult;
 703             }
 704             $parent = $child;
 705         }
 706         my $uid = $parent->getUID;
 707         $c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
 708         $action = "!$action";
 709     }
 710     else { $c->actions->{plain}->{$action} = [ $namespace, $code ] }
 711     my $reverse = $prefix ? "$action ($prefix)" : $action;
 712     $c->actions->{reverse}->{"$code"} = $reverse;
 713     $c->log->debug(qq/"$namespace" defined "$action" as "$code"/) if $c->debug;
 714 }
 715
 716 =item $class->setup
 717
 718 Setup.
 719
 720     MyApp->setup;
 721
 722 =cut
 723
 724 sub setup {
 725     my $self = shift;
 726     $self->setup_components;
 727     if ( $self->debug ) {
 728         my $name = $self->config->{name} || 'Application';
 729         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 730     }
 731 }
 732
 733 =item $class->setup_components
 734
 735 Setup components.
 736
 737 =cut
 738
 739 sub setup_components {
 740     my $self = shift;
 741
 742     # Components
 743     my $class = ref $self || $self;
 744     eval <<"";
 745         package $class;
 746         import Module::Pluggable::Fast
 747           name   => '_components',
 748           search => [
 749             '$class\::Controller', '$class\::C',
 750             '$class\::Model',      '$class\::M',
 751             '$class\::View',       '$class\::V'
 752           ];
 753
 754     if ( my $error = $@ ) {
 755         chomp $error;
 756         $self->log->error(
 757             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 758     }
 759     $self->components( {} );
 760     for my $component ( $self->_components($self) ) {
 761         $self->components->{ ref $component } = $component;
 762     }
 763     $self->log->debug( 'Initialized components "'
 764           . join( ' ', keys %{ $self->components } )
 765           . '"' )
 766       if $self->debug;
 767 }
 768
 769 =item $c->stash
 770
 771 Returns a hashref containing all your data.
 772
 773     $c->stash->{foo} ||= 'yada';
 774     print $c->stash->{foo};
 775
 776 =cut
 777
 778 sub stash {
 779     my $self = shift;
 780     if ( $_[0] ) {
 781         my $stash = $_[1] ? {@_} : $_[0];
 782         while ( my ( $key, $val ) = each %$stash ) {
 783             $self->{stash}->{$key} = $val;
 784         }
 785     }
 786     return $self->{stash};
 787 }
 788
 789 sub _prefix {
 790     my ( $class, $name ) = @_;
 791     my $prefix = _class2prefix($class);
 792     warn "$class - $name - $prefix";
 793     $name = "$prefix/$name" if $prefix;
 794     return $name;
 795 }
 796
 797 sub _class2prefix {
 798     my $class = shift || '';
 799     $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
 800     my $prefix = lc $2 || '';
 801     $prefix =~ s/\:\:/\//g;
 802     return $prefix;
 803 }
 804
 805 =back
 806
 807 =head1 AUTHOR
 808
 809 Sebastian Riedel, C<sri@cpan.org>
 810
 811 =head1 COPYRIGHT
 812
 813 This program is free software, you can redistribute it and/or modify it under
 814 the same terms as Perl itself.
 815
 816 =cut
 817
 818 1;