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