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